pax_global_header00006660000000000000000000000064132501655040014513gustar00rootroot0000000000000052 comment=297bbe7d0b236633425e3624c16fb94c1e0a317f ruby-lapack-1.8.1/000077500000000000000000000000001325016550400137345ustar00rootroot00000000000000ruby-lapack-1.8.1/COPYING000077500000000000000000000047211325016550400147760ustar00rootroot00000000000000Ruby-lapack is copyrighted free software by Seiya Nishizawa . You can redistribute it and/or modify it under either the terms of the GPL version 2 (see the file GPL), or the conditions below: 1. You may make and give away verbatim copies of the source form of the software without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may modify your copy of the software in any way, provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or by allowing the author to include your modifications in the software. b) use the modified software only within your corporation or organization. c) give non-standard binaries non-standard names, with instructions on where to get the original software distribution. d) make other distribution arrangements with the author. 3. You may distribute the software in object code or binary form, provided that you do at least ONE of the following: a) distribute the binaries and library files of the software, together with instructions (in the manual page or equivalent) on where to get the original distribution. b) accompany the distribution with the machine-readable source of the software. c) give non-standard binaries non-standard names, with instructions on where to get the original software distribution. d) make other distribution arrangements with the author. 4. You may modify and include the part of the software into any other software (possibly commercial). But some files in the distribution are not written by the author, so that they are not under these terms. For the list of those files and their copying conditions, see the file LEGAL. 5. The scripts and library files supplied as input to or produced as output from the software do not automatically fall under the copyright of the software, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this software. 6. THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. ruby-lapack-1.8.1/GPL000077500000000000000000000431311325016550400143060ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. ruby-lapack-1.8.1/README.rdoc000077500000000000000000000046311325016550400155510ustar00rootroot00000000000000= 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. ruby-lapack-1.8.1/Rakefile000077500000000000000000000057031325016550400154110ustar00rootroot00000000000000require "rubygems" require "rubygems/package_task" require "rake/clean" require "rake/testtask" version = "1.8.1" target_prefix = "numru" # get options destdir = ENV["DESTDIR"] || "" libdir = ENV["SITELIBDIR"] || RbConfig::CONFIG["sitelibdir"] archdir = ENV["SITEARCHDIR"] || RbConfig::CONFIG["sitearchdir"] config_opts = ENV["CONFIG_OPTIONS"] NAME = "lapack" LIBS = FileList["lib/#{target_prefix}/*rb"] case RbConfig::CONFIG["host_os"] when /darwin/ extension = "bundle" else extension = "so" end DLLIB = "ext/#{NAME}.#{extension}" so_file = File.join("lib", target_prefix, "#{NAME}.#{extension}") 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 => 0644 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 = < binary_pkg file binary_pkg => gem_pkg do system "gem compile --fat 1.8:ruby1.8,1.9:ruby1.9 #{gem_pkg}" end ruby-lapack-1.8.1/dev/000077500000000000000000000000001325016550400145125ustar00rootroot00000000000000ruby-lapack-1.8.1/dev/common.rb000077500000000000000000000007261325016550400163370ustar00rootroot00000000000000def 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(/ilatrans_\([^)]+\)/,",").gsub(/ilaenv_\(([^,]+),[^,]+/,'\1').gsub(/[\(\)\+\-\*\/:\?=\&\|]+/,",").split(",").each{|d| d.strip! next if (d == "") || (/^\d+(\.\d+)?$/ =~ d) || /^\"[^\"]+\"$/ =~ d || d=="int" || d=="double" ary.push d } ary end ruby-lapack-1.8.1/dev/defs/000077500000000000000000000000001325016550400154335ustar00rootroot00000000000000ruby-lapack-1.8.1/dev/defs/cbbcsd000077500000000000000000000222201325016550400165770ustar00rootroot00000000000000--- :name: cbbcsd :md5sum: 7e10136e0faadfd9b81e31ecfe50ed65 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: real :intent: input/output :dims: - q - phi: :type: real :intent: input :dims: - q-1 - u1: :type: complex :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: complex :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: complex :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: complex :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: real :intent: output :dims: - q - b11e: :type: real :intent: output :dims: - q-1 - b12d: :type: real :intent: output :dims: - q - b12e: :type: real :intent: output :dims: - q-1 - b21d: :type: real :intent: output :dims: - q - b21e: :type: real :intent: output :dims: - q-1 - b22d: :type: real :intent: output :dims: - q - b22e: :type: real :intent: output :dims: - q-1 - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: lrwork: MAX(1,8*q) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cbdsqr000077500000000000000000000157411325016550400166470ustar00rootroot00000000000000--- :name: cbdsqr :md5sum: 2ab59917ff5e0610f9099f32c4b9bca8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - vt: :type: complex :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: complex :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - "(ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbbrd000077500000000000000000000116151325016550400166100ustar00rootroot00000000000000--- :name: cgbbrd :md5sum: b3d52b28be53961bb824695caf6d2471 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - q: :type: complex :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: complex :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(m,n) - rwork: :type: real :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbcon000077500000000000000000000064371325016550400166260ustar00rootroot00000000000000--- :name: cgbcon :md5sum: 8e6b7e041c6298e0552aa8c039013d30 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbequ000077500000000000000000000074001325016550400166300ustar00rootroot00000000000000--- :name: cgbequ :md5sum: 8fc652d617124429e7e171353face8d7 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - MAX(1,m) - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbequb000077500000000000000000000102541325016550400167730ustar00rootroot00000000000000--- :name: cgbequb :md5sum: 5041799a7d0f357f5d903a9c34b04f02 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbrfs000077500000000000000000000126331325016550400166340ustar00rootroot00000000000000--- :name: cgbrfs :md5sum: b26da869b9502286688e2b2960b3e223 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbrfsx000077500000000000000000000424201325016550400170210ustar00rootroot00000000000000--- :name: cgbrfsx :md5sum: 28dea64997d0d586014683ff61054a97 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbsv000077500000000000000000000114611325016550400164700ustar00rootroot00000000000000--- :name: cgbsv :md5sum: be2a69ee36b53e7064810d3a8ed3d66f :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbsvx000077500000000000000000000344601325016550400166640ustar00rootroot00000000000000--- :name: cgbsvx :md5sum: ec265f99c9de3a8c59cb298793c1ae74 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/cgbsvxx000077500000000000000000000563731325016550400170630ustar00rootroot00000000000000--- :name: cgbsvxx :md5sum: 801194546c21b97849616b544a6977ee :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/cgbtf2000077500000000000000000000074261325016550400165410ustar00rootroot00000000000000--- :name: cgbtf2 :md5sum: 874bb87107feab33bcca8057b0073bac :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbtrf000077500000000000000000000074131325016550400166350ustar00rootroot00000000000000--- :name: cgbtrf :md5sum: cb767c902d74f024a5a58dad38d41372 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgbtrs000077500000000000000000000060161325016550400166500ustar00rootroot00000000000000--- :name: cgbtrs :md5sum: e6189618958ef743907bab8b81357369 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgebak000077500000000000000000000054441325016550400166040ustar00rootroot00000000000000--- :name: cgebak :md5sum: ec4f808992cd580a6d84750daf885382 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgebal000077500000000000000000000103771325016550400166060ustar00rootroot00000000000000--- :name: cgebal :md5sum: 0465840854417f9abafe565179296d65 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgebd2000077500000000000000000000131641325016550400165140ustar00rootroot00000000000000--- :name: cgebd2 :md5sum: 4e86e4849b5df918a38a3984c6f19adf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: complex :intent: output :dims: - MIN(m,n) - taup: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgebrd000077500000000000000000000144621325016550400166160ustar00rootroot00000000000000--- :name: cgebrd :md5sum: 95dd155a09e64e05937c7a60f152d9f3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: complex :intent: output :dims: - MIN(m,n) - taup: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgecon000077500000000000000000000047421325016550400166260ustar00rootroot00000000000000--- :name: cgecon :md5sum: f5f1bbadb10b69b8f3ee9c60dc75b75c :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeequ000077500000000000000000000064261325016550400166420ustar00rootroot00000000000000--- :name: cgeequ :md5sum: b5e1f650b307e4997d54c66b11f94248 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeequb000077500000000000000000000072561325016550400170060ustar00rootroot00000000000000--- :name: cgeequb :md5sum: f1ca33c27f777c5067e5fd5df188aa3e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgees000077500000000000000000000135271325016550400164570ustar00rootroot00000000000000--- :name: cgees :md5sum: ada518051342c4def9d30ad41b0a7f31 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: complex - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: complex :intent: output :dims: - n - vs: :type: complex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeesx000077500000000000000000000173151325016550400166460ustar00rootroot00000000000000--- :name: cgeesx :md5sum: 239541f0bcff569087e91823b8128f20 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: complex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: complex :intent: output :dims: - n - vs: :type: complex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: real :intent: output - rcondv: :type: real :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeev000077500000000000000000000114221325016550400164520ustar00rootroot00000000000000--- :name: cgeev :md5sum: 27dac225d8198b6ac4bce5bc6918a90a :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeevx000077500000000000000000000227441325016550400166530ustar00rootroot00000000000000--- :name: cgeevx :md5sum: 9f6e8ef099565cc5fbc0ff1866d22dcc :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgegs000077500000000000000000000156101325016550400164540ustar00rootroot00000000000000--- :name: cgegs :md5sum: 0d915b089b60c924c71d32fe45a153c2 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vsl: :type: complex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: complex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgegv000077500000000000000000000234121325016550400164560ustar00rootroot00000000000000--- :name: cgegv :md5sum: 4bb3b3ee105dc84e3a06b33c6db1feee :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgehd2000077500000000000000000000073611325016550400165240ustar00rootroot00000000000000--- :name: cgehd2 :md5sum: 8450267c1a4d71c520945ff6f0d8610b :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - n-1 - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgehrd000077500000000000000000000113101325016550400166110ustar00rootroot00000000000000--- :name: cgehrd :md5sum: fe31e41de8aa4f616eac2734fd86700f :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgelq2000077500000000000000000000047571325016550400165530ustar00rootroot00000000000000--- :name: cgelq2 :md5sum: b8fcc5877fd42da3a6c7800e8a8bec97 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgelqf000077500000000000000000000072271325016550400166320ustar00rootroot00000000000000--- :name: cgelqf :md5sum: b75f05b1c6941e97fc9d81c962662fb8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgels000077500000000000000000000132531325016550400164620ustar00rootroot00000000000000--- :name: cgels :md5sum: 29da08d26d560d2b4db9388e142fdc4c :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/cgelsd000077500000000000000000000173051325016550400166300ustar00rootroot00000000000000--- :name: cgelsd :md5sum: 5a0063a066f735f77a3b1eb3f1e27edc :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "m>=n ? 2*n+n*nrhs : 2*m+m*nrhs" - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - info: :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))) 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)" nlvl: MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0))) smlsiz: ilaenv_(&c__9,"CGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " 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 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 transformations 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" ruby-lapack-1.8.1/dev/defs/cgelss000077500000000000000000000117031325016550400166430ustar00rootroot00000000000000--- :name: cgelss :md5sum: 62422f6642a76bd0d56d9f0cc0a57940 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 5*MIN(m,n) - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/cgelsx000077500000000000000000000122031325016550400166440ustar00rootroot00000000000000--- :name: cgelsx :md5sum: aa91b952fb4647943c51d9489763bd18 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs) - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgelsy000077500000000000000000000146371325016550400166620ustar00rootroot00000000000000--- :name: cgelsy :md5sum: 2279e3c93a99cd72baf9f763012d87ce :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 2*n - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/cgeql2000077500000000000000000000051301325016550400165350ustar00rootroot00000000000000--- :name: cgeql2 :md5sum: e094d31e3478cc3db98bef235a365dbd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqlf000077500000000000000000000074461325016550400166350ustar00rootroot00000000000000--- :name: cgeqlf :md5sum: aa37cd9c6d3b8da0b377cd981fb69997 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqp3000077500000000000000000000075631325016550400165560ustar00rootroot00000000000000--- :name: cgeqp3 :md5sum: ab6cee8b274b134af89a8741b7884457 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n+1 - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqpf000077500000000000000000000066311325016550400166340ustar00rootroot00000000000000--- :name: cgeqpf :md5sum: 79525820621b8a0f82b1e8ed75e0eceb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqr2000077500000000000000000000047361325016550400165560ustar00rootroot00000000000000--- :name: cgeqr2 :md5sum: 114a90186ffc7d77d59e5b0de91cafc3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqr2p000077500000000000000000000047411325016550400167320ustar00rootroot00000000000000--- :name: cgeqr2p :md5sum: fd03ae20ad3f07feeda91959e82ee8fb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqrf000077500000000000000000000072451325016550400166400ustar00rootroot00000000000000--- :name: cgeqrf :md5sum: 636ef6ebfc4f9933d33fe673fb47e58d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgeqrfp000077500000000000000000000072511325016550400170150ustar00rootroot00000000000000--- :name: cgeqrfp :md5sum: cd46368a177f80fac9067f36e868f8d9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgerfs000077500000000000000000000111361325016550400166340ustar00rootroot00000000000000--- :name: cgerfs :md5sum: 159d9fe35bc1f2e3a27de2ef0371b704 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgerfsx000077500000000000000000000400221325016550400170200ustar00rootroot00000000000000--- :name: cgerfsx :md5sum: cec9f6b6b9086e460046d7894e0616dd :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgerq2000077500000000000000000000051471325016550400165530ustar00rootroot00000000000000--- :name: cgerq2 :md5sum: 5c2737c86fa799ea149918e61f3f15a4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgerqf000077500000000000000000000074701325016550400166400ustar00rootroot00000000000000--- :name: cgerqf :md5sum: 4f88b7a5d03b29c9016c5f0e7ecefe20 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgesc2000077500000000000000000000045241325016550400165340ustar00rootroot00000000000000--- :name: cgesc2 :md5sum: 0ec1cb4fcf962fa0ec5a158eaccd46cf :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: complex :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgesdd000077500000000000000000000174751325016550400166300ustar00rootroot00000000000000--- :name: cgesdd :md5sum: 22c0a1340de32a426796a6de2e6183b9 :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: complex :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: complex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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)))" - iwork: :type: integer :intent: workspace :dims: - 8*MIN(m,n) - info: :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\") || 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\ *\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" ruby-lapack-1.8.1/dev/defs/cgesv000077500000000000000000000060571325016550400165000ustar00rootroot00000000000000--- :name: cgesv :md5sum: 261cd82623a43e575e6bd00ede93a7d3 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgesvd000077500000000000000000000161741325016550400166450ustar00rootroot00000000000000--- :name: cgesvd :md5sum: 31811375e47d4ef59153bb7b2e7b0db7 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: complex :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: complex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1, 2*MIN(m,n)+MAX(m,n)) - rwork: :type: real :intent: workspace :dims: - 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 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" ruby-lapack-1.8.1/dev/defs/cgesvx000077500000000000000000000323671325016550400166730ustar00rootroot00000000000000--- :name: cgesvx :md5sum: 63167ffcd212fc9e1f2cb1f47cca7e74 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: output :dims: - 2*n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/cgesvxx000077500000000000000000000547641325016550400170700ustar00rootroot00000000000000--- :name: cgesvxx :md5sum: f33bd5ec25f783a870ac91682bc5f189 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: n n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/cgetc2000077500000000000000000000050311325016550400165270ustar00rootroot00000000000000--- :name: cgetc2 :md5sum: 0e098d8f352fe876de5f103e8d0d40d5 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgetf2000077500000000000000000000045251325016550400165410ustar00rootroot00000000000000--- :name: cgetf2 :md5sum: 132de400e395cb5fa9f26913324c405d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgetrf000077500000000000000000000045331325016550400166400ustar00rootroot00000000000000--- :name: cgetrf :md5sum: ca5ce5932bcc96bfb579e9e88aabe52b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgetri000077500000000000000000000052101325016550400166340ustar00rootroot00000000000000--- :name: cgetri :md5sum: 9ecd491ae64a30ddedf4b8b8b8b65820 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgetrs000077500000000000000000000047331325016550400166570ustar00rootroot00000000000000--- :name: cgetrs :md5sum: 3baee94e1ac511afdeae03d88c6f52a6 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggbak000077500000000000000000000073631325016550400166100ustar00rootroot00000000000000--- :name: cggbak :md5sum: 28692fd5b96d1bf97c9bbba05c793325 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: real :intent: input :dims: - n - rscale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggbal000077500000000000000000000117141325016550400166040ustar00rootroot00000000000000--- :name: cggbal :md5sum: c943f265fd54c6aa73b300bdb1dec322 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgges000077500000000000000000000213071325016550400164540ustar00rootroot00000000000000--- :name: cgges :md5sum: 2194034394c6047cf7a6bae40d20e0c0 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: complex - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vsl: :type: complex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: complex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 8*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggesx000077500000000000000000000264641325016550400166550ustar00rootroot00000000000000--- :name: cggesx :md5sum: 2f0b8d24265696a975f64dcdb1eefeec :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: complex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vsl: :type: complex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: complex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: real :intent: output :dims: - "2" - rcondv: :type: real :intent: output :dims: - "2" - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 8*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggev000077500000000000000000000147071325016550400164650ustar00rootroot00000000000000--- :name: cggev :md5sum: 31b6e9522945246c5ec67cadb581319d :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,2*n) - rwork: :type: real :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggevx000077500000000000000000000316101325016550400166450ustar00rootroot00000000000000--- :name: cggevx :md5sum: 6749d93a340b1974b08908ef409f99e7 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - bbnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - lrwork - iwork: :type: integer :intent: workspace :dims: - "lsame_(&sense,\"E\") ? 0 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" lrwork: "((lsame_(&balanc,\"S\")) || (lsame_(&balanc,\"B\"))) ? MAX(1,6*n) : MAX(1,2*n)" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggglm000077500000000000000000000122561325016550400166270ustar00rootroot00000000000000--- :name: cggglm :md5sum: 52c910bf2bf7160e16593f1ec7fc216f :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: complex :intent: input/output :dims: - n - x: :type: complex :intent: output :dims: - m - y: :type: complex :intent: output :dims: - p - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgghrd000077500000000000000000000134431325016550400166240ustar00rootroot00000000000000--- :name: cgghrd :md5sum: 62029756327bc968ec07529087b0e19a :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgglse000077500000000000000000000121101325016550400166200ustar00rootroot00000000000000--- :name: cgglse :md5sum: 76651864baa26d2d1471eeda133757a5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - m - d: :type: complex :intent: input/output :dims: - p - x: :type: complex :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggqrf000077500000000000000000000155511325016550400166410ustar00rootroot00000000000000--- :name: cggqrf :md5sum: a13fa854c2926b10d6ea7e667ca8049f :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: complex :intent: output :dims: - MIN(n,m) - b: :type: complex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: complex :intent: output :dims: - MIN(n,p) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggrqf000077500000000000000000000155131325016550400166370ustar00rootroot00000000000000--- :name: cggrqf :md5sum: f971670b151a75a72622c3d66873201a :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: complex :intent: output :dims: - MIN(m,n) - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: complex :intent: output :dims: - MIN(p,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cggsvd000077500000000000000000000244131325016550400166420ustar00rootroot00000000000000--- :name: cggsvd :md5sum: c979f406eb76f93acff2a1803459b120 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: complex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: complex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(3*n,m - p)+n - rwork: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: 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" :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\ * 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" ruby-lapack-1.8.1/dev/defs/cggsvp000077500000000000000000000154031325016550400166550ustar00rootroot00000000000000--- :name: cggsvp :md5sum: 73af048d60b53bf36e8099ec211860d9 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: complex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: complex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 2*n - tau: :type: complex :intent: workspace :dims: - n - work: :type: complex :intent: workspace :dims: - MAX(3*n,m - p) - info: :type: integer :intent: output :substitutions: 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" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgtcon000077500000000000000000000063661325016550400166510ustar00rootroot00000000000000--- :name: cgtcon :md5sum: e46b7760f66cc206300c78aed26370b3 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgtrfs000077500000000000000000000126731325016550400166620ustar00rootroot00000000000000--- :name: cgtrfs :md5sum: 40687df2803e8c7314702e4c54e11070 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - dlf: :type: complex :intent: input :dims: - n-1 - df: :type: complex :intent: input :dims: - n - duf: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgtsv000077500000000000000000000056131325016550400165140ustar00rootroot00000000000000--- :name: cgtsv :md5sum: 70ece7626a7de0599058891e16ed41ae :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input/output :dims: - n-1 - d: :type: complex :intent: input/output :dims: - n - du: :type: complex :intent: input/output :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgtsvx000077500000000000000000000233031325016550400167000ustar00rootroot00000000000000--- :name: cgtsvx :md5sum: ed2cc77d71ddf8dbdd89532429553bc3 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - dlf: :type: complex :intent: input/output :dims: - n-1 - df: :type: complex :intent: input/output :dims: - n - duf: :type: complex :intent: input/output :dims: - n-1 - du2: :type: complex :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgttrf000077500000000000000000000060731325016550400166600ustar00rootroot00000000000000--- :name: cgttrf :md5sum: 113d7a17d7e56d36b76493ceda5cfa3e :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: complex :intent: input/output :dims: - n-1 - d: :type: complex :intent: input/output :dims: - n - du: :type: complex :intent: input/output :dims: - n-1 - du2: :type: complex :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgttrs000077500000000000000000000067671325016550400167070ustar00rootroot00000000000000--- :name: cgttrs :md5sum: 2ee48e0bb1e224a8e456011f2c24bf31 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cgtts2000077500000000000000000000061001325016550400165640ustar00rootroot00000000000000--- :name: cgtts2 :md5sum: 1de5c22ebf43da7af448137202541249 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbev000077500000000000000000000075561325016550400164650ustar00rootroot00000000000000--- :name: chbev :md5sum: 1cdc22adcd288b6f426c659c21190424 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbevd000077500000000000000000000163541325016550400166250ustar00rootroot00000000000000--- :name: chbevd :md5sum: ffa41f3f4c98922918cb3981415422ec :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbevx000077500000000000000000000176221325016550400166500ustar00rootroot00000000000000--- :name: chbevx :md5sum: e914f49f4d5aed935f95c281139db9ec :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbgst000077500000000000000000000100471325016550400166350ustar00rootroot00000000000000--- :name: chbgst :md5sum: 50629657aeecc3af421f07faa75dcb16 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbgv000077500000000000000000000130121325016550400164470ustar00rootroot00000000000000--- :name: chbgv :md5sum: dddbffb87a4a98ff464f760034bc1a42 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbgvd000077500000000000000000000207661325016550400166310ustar00rootroot00000000000000--- :name: chbgvd :md5sum: 0a1e2904f0c5dc3042474aee2dd3aade :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chbgvx000077500000000000000000000216341325016550400166500ustar00rootroot00000000000000--- :name: chbgvx :md5sum: 994b0281e65266e3f6c89ad887294c10 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" 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\ *\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" ruby-lapack-1.8.1/dev/defs/chbtrd000077500000000000000000000100361325016550400166270ustar00rootroot00000000000000--- :name: chbtrd :md5sum: 58603e69db2395aacc0af96c113a10e7 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/checon000077500000000000000000000051561325016550400166270ustar00rootroot00000000000000--- :name: checon :md5sum: 4a474de24c651dfefc9c44d20ce9de0c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cheequb000077500000000000000000000051141325016550400167760ustar00rootroot00000000000000--- :name: cheequb :md5sum: 9a7a2379d8ae799e5f48006ed943636f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cheev000077500000000000000000000070261325016550400164600ustar00rootroot00000000000000--- :name: cheev :md5sum: 149dbe00ca97a680aa0d60555b346c6d :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cheevd000077500000000000000000000154511325016550400166250ustar00rootroot00000000000000--- :name: cheevd :md5sum: 155bc4bab8cfde8184298cbef514de86 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cheevr000077500000000000000000000320001325016550400166300ustar00rootroot00000000000000--- :name: cheevr :md5sum: 9d3a30fde6d44c5d3a22bf2f8b026b5b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 24*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cheevx000077500000000000000000000176011325016550400166500ustar00rootroot00000000000000--- :name: cheevx :md5sum: 16e52f5a970fe326d98bf7b6bca8e538 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 2*n" - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chegs2000077500000000000000000000057421325016550400165440ustar00rootroot00000000000000--- :name: chegs2 :md5sum: a0d46b53c7c5c0b238a824e94376e3ae :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chegst000077500000000000000000000057371325016550400166520ustar00rootroot00000000000000--- :name: chegst :md5sum: 79db73907714c6262f9a3ff4c9fb3ec7 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chegv000077500000000000000000000126131325016550400164600ustar00rootroot00000000000000--- :name: chegv :md5sum: 937cc653b6096de55edba381f27843d8 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chegvd000077500000000000000000000213041325016550400166210ustar00rootroot00000000000000--- :name: chegvd :md5sum: fbd11500a15f1d490decf2761cdee3d4 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chegvx000077500000000000000000000233151325016550400166510ustar00rootroot00000000000000--- :name: chegvx :md5sum: b4362162a760701dc3d2cf4c491046f0 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cherfs000077500000000000000000000121501325016550400166320ustar00rootroot00000000000000--- :name: cherfs :md5sum: d7c39ab75eb88e3a1a1e8ea96480eedf :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cherfsx000077500000000000000000000373361325016550400170370ustar00rootroot00000000000000--- :name: cherfsx :md5sum: 8e75c5c0cefc0676f16ef4c51513f6e6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chesv000077500000000000000000000127001325016550400164710ustar00rootroot00000000000000--- :name: chesv :md5sum: 3e767c9c17a6d72984bc45f1aa42a2c2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chesvx000077500000000000000000000234011325016550400166610ustar00rootroot00000000000000--- :name: chesvx :md5sum: 4374c03c50dbc833b7b3725c7ed3611d :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chesvxx000077500000000000000000000513151325016550400170560ustar00rootroot00000000000000--- :name: chesvxx :md5sum: 3b7d96ee13fb907e462bbb16f1bba231 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/chetd2000077500000000000000000000115631325016550400165400ustar00rootroot00000000000000--- :name: chetd2 :md5sum: 71b4642e8124d75edc818a52bbfcacc7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chetf2000077500000000000000000000130761325016550400165430ustar00rootroot00000000000000--- :name: chetf2 :md5sum: 05305896b5675db360a8faa279e8a94d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chetrd000077500000000000000000000130711325016550400166340ustar00rootroot00000000000000--- :name: chetrd :md5sum: 90032415c41efdbcc206a1786bcc8b9e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chetrf000077500000000000000000000140111325016550400166310ustar00rootroot00000000000000--- :name: chetrf :md5sum: f5e1a64640b9b7eecf825c98401cf6ac :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chetri000077500000000000000000000050551325016550400166440ustar00rootroot00000000000000--- :name: chetri :md5sum: 4e4e236c2f9985d6b90601dcc470436a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chetrs000077500000000000000000000047661325016550400166660ustar00rootroot00000000000000--- :name: chetrs :md5sum: b88885fcd9819045364766485aed2ea1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chetrs2000077500000000000000000000052401325016550400167340ustar00rootroot00000000000000--- :name: chetrs2 :md5sum: cd636966a24cd1a9a753a4dcf2c8b77c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chfrk000077500000000000000000000106141325016550400164600ustar00rootroot00000000000000--- :name: chfrk :md5sum: 08bd40053c967bb77e3ab340f3a09c2b :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: complex :intent: input :dims: - lda - "lsame_(&trans,\"N\") ? k : n" - lda: :type: integer :intent: input - beta: :type: real :intent: input - c: :type: complex :intent: input/output :dims: - 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\ *\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" ruby-lapack-1.8.1/dev/defs/chgeqz000077500000000000000000000223411325016550400166440ustar00rootroot00000000000000--- :name: chgeqz :md5sum: 8994134138840bb33bb79c034bde7992 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chla_transtype000077500000000000000000000020751325016550400204050ustar00rootroot00000000000000--- :name: chla_transtype :md5sum: 72653dbad54122949a79d609236e064b :category: :function :type: char :arguments: - trans: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpcon000077500000000000000000000050151325016550400166340ustar00rootroot00000000000000--- :name: chpcon :md5sum: 45e9e05f044d66f178f8b343741c88fd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpev000077500000000000000000000067521325016550400165000ustar00rootroot00000000000000--- :name: chpev :md5sum: 526bd4ade00201871894a1f1c53fa307 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpevd000077500000000000000000000154361325016550400166430ustar00rootroot00000000000000--- :name: chpevd :md5sum: 27230956d597f9d089a7156bcfa7b173 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpevx000077500000000000000000000162561325016550400166700ustar00rootroot00000000000000--- :name: chpevx :md5sum: 5df9981285d3b1ae5440a199960342f7 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpgst000077500000000000000000000051121325016550400166500ustar00rootroot00000000000000--- :name: chpgst :md5sum: 1a890303b2501ebc28a37ce6b73eedd1 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - bp: :type: complex :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpgv000077500000000000000000000121231325016550400164670ustar00rootroot00000000000000--- :name: chpgv :md5sum: 9f30ab07cf54461d441f623e4a879060 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - bp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpgvd000077500000000000000000000210261325016550400166350ustar00rootroot00000000000000--- :name: chpgvd :md5sum: 64f7065ad380a8ee00723d15be61d9d1 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - bp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpgvx000077500000000000000000000220521325016550400166610ustar00rootroot00000000000000--- :name: chpgvx :md5sum: 04980cf924a1957e030573a32bc6b72c :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - bp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chprfs000077500000000000000000000113421325016550400166470ustar00rootroot00000000000000--- :name: chprfs :md5sum: 4d6e9e2939bf43ccc422bd54c7607c95 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpsv000077500000000000000000000115401325016550400165050ustar00rootroot00000000000000--- :name: chpsv :md5sum: 1791c2ef87d8451f3b148e7bd5f756d0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chpsvx000077500000000000000000000225141325016550400167000ustar00rootroot00000000000000--- :name: chpsvx :md5sum: 85de40ec51043497622de651889992fd :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chptrd000077500000000000000000000076571325016550400166640ustar00rootroot00000000000000--- :name: chptrd :md5sum: a3029585e3226a50f649c5b9511928e4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chptrf000077500000000000000000000115261325016550400166540ustar00rootroot00000000000000--- :name: chptrf :md5sum: 227b4ab1f5a1280f310d5961364b711c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chptri000077500000000000000000000047111325016550400166550ustar00rootroot00000000000000--- :name: chptri :md5sum: bfa738a7c12419c2627e1a41ebd75c72 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chptrs000077500000000000000000000046451325016550400166750ustar00rootroot00000000000000--- :name: chptrs :md5sum: 7f2d33532d7caeda7fca44e1cfb4346c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chsein000077500000000000000000000166331325016550400166430ustar00rootroot00000000000000--- :name: chsein :md5sum: 47f76f0ff879b1035b2920625919b141 :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - h: :type: complex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: input/output :dims: - n - vl: :type: complex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - n*n - rwork: :type: real :intent: workspace :dims: - n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/chseqr000077500000000000000000000262741325016550400166610ustar00rootroot00000000000000--- :name: chseqr :md5sum: b7398af14f809c4ce963b655e29f282d :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - z: :type: complex :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gbamv000077500000000000000000000120321325016550400172720ustar00rootroot00000000000000--- :name: cla_gbamv :md5sum: 6fdc0ec1e9d677c211aaed9e1e36bb0c :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: real :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: real :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: ldab: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gbrcond_c000077500000000000000000000105471325016550400201270ustar00rootroot00000000000000--- :name: cla_gbrcond_c :md5sum: 67b30cebe554e4047e0ef184e9efd72e :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gbrcond_x000077500000000000000000000102771325016550400201540ustar00rootroot00000000000000--- :name: cla_gbrcond_x :md5sum: 752539b13b6724667a3fba3025ec4a6b :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gbrfsx_extended000077500000000000000000000357761325016550400213750ustar00rootroot00000000000000--- :name: cla_gbrfsx_extended :md5sum: 14debaef2e540705026327e958a0fff4 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - lda - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldaf - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: ldafb: ldaf = MAX(1,n) ldab: lda = MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gbrpvgrw000077500000000000000000000060101325016550400200350ustar00rootroot00000000000000--- :name: cla_gbrpvgrw :md5sum: 6ebe3ad7622d703a0633348eddaf80d8 :category: :function :type: real :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_geamv000077500000000000000000000113051325016550400172770ustar00rootroot00000000000000--- :name: cla_geamv :md5sum: 03b3c0c36a18cc3eacd0b6c465971c1e :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gercond_c000077500000000000000000000071751325016550400201350ustar00rootroot00000000000000--- :name: cla_gercond_c :md5sum: 973bbc06a0c6b2901d91af027d777425 :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gercond_x000077500000000000000000000067571325016550400201670ustar00rootroot00000000000000--- :name: cla_gercond_x :md5sum: 901839bd8115eba9bf98a6db1f4b7bb9 :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_gerfsx_extended000077500000000000000000000350541325016550400213650ustar00rootroot00000000000000--- :name: cla_gerfsx_extended :md5sum: 12ca37550f11461056c380e1b73caeff :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - errs_n: :type: real :intent: input/output :dims: - nrhs - n_norms - errs_c: :type: real :intent: input/output :dims: - nrhs - n_norms - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n_norsm: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_heamv000077500000000000000000000111411325016550400172760ustar00rootroot00000000000000--- :name: cla_heamv :md5sum: a9e12928b232d452b69031ceb12d1748 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_hercond_c000077500000000000000000000067221325016550400201330ustar00rootroot00000000000000--- :name: cla_hercond_c :md5sum: a663416c99cd3cb30e966cfb58383a71 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_hercond_x000077500000000000000000000064351325016550400201610ustar00rootroot00000000000000--- :name: cla_hercond_x :md5sum: 92fff2de9005dc3e2f76fc1542552543 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_herfsx_extended000077500000000000000000000347231325016550400213700ustar00rootroot00000000000000--- :name: cla_herfsx_extended :md5sum: ec85b6e9843f94e54689deb25b562e34 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_herpvgrw000077500000000000000000000062271325016550400200530ustar00rootroot00000000000000--- :name: cla_herpvgrw :md5sum: f26107fad597783e3c6c1c2b8110cc14 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_lin_berr000077500000000000000000000052331325016550400177770ustar00rootroot00000000000000--- :name: cla_lin_berr :md5sum: 6b8eeecaaa46d0e73b99de53d6d4b511 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: doublereal :intent: input :dims: - n - nrhs - ayb: :type: doublereal :intent: input :dims: - n - nrhs - berr: :type: complex :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_porcond_c000077500000000000000000000064131325016550400201520ustar00rootroot00000000000000--- :name: cla_porcond_c :md5sum: f6e9460efbf813d2f7b6ca569b512d8e :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_porcond_x000077500000000000000000000061001325016550400201700ustar00rootroot00000000000000--- :name: cla_porcond_x :md5sum: ec4ec54a78c42bf0a9779386bc95ac15 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_porfsx_extended000077500000000000000000000343421325016550400214070ustar00rootroot00000000000000--- :name: cla_porfsx_extended :md5sum: 12869e888f1a7be8b7bedeec770f0481 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_porpvgrw000077500000000000000000000051441325016550400200720ustar00rootroot00000000000000--- :name: cla_porpvgrw :md5sum: b6254f02ecd607ce251062879936c907 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: complex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_rpvgrw000077500000000000000000000044071325016550400175340ustar00rootroot00000000000000--- :name: cla_rpvgrw :md5sum: 6ea05cda1b7eeeb5b354576bf4a33b68 :category: :function :type: real :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_syamv000077500000000000000000000111411325016550400173350ustar00rootroot00000000000000--- :name: cla_syamv :md5sum: 191e7c227fca4a3845d40fa60b7eaa53 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: n: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_syrcond_c000077500000000000000000000067351325016550400201760ustar00rootroot00000000000000--- :name: cla_syrcond_c :md5sum: 3f35d193001e0256810e7243a7795ae5 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_syrcond_x000077500000000000000000000065041325016550400202150ustar00rootroot00000000000000--- :name: cla_syrcond_x :md5sum: 3ac4221b1dcc11fa685d99f3692f1e54 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_syrfsx_extended000077500000000000000000000347231325016550400214270ustar00rootroot00000000000000--- :name: cla_syrfsx_extended :md5sum: 72b90b5cfd7630e9b07d0fa1740b3534 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_syrpvgrw000077500000000000000000000062621325016550400201110ustar00rootroot00000000000000--- :name: cla_syrpvgrw :md5sum: e96ba2f50c224c0fa1b51d9376552070 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cla_wwaddw000077500000000000000000000026061325016550400175010ustar00rootroot00000000000000--- :name: cla_wwaddw :md5sum: e6fda1b93199f58e559cbd022af359dc :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - n - y: :type: complex :intent: input/output :dims: - n - w: :type: complex :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clabrd000077500000000000000000000145711325016550400166200ustar00rootroot00000000000000--- :name: clabrd :md5sum: 6ef5300c03ff0c0ef1c02f7f2da050d5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MAX(1,nb) - e: :type: real :intent: output :dims: - MAX(1,nb) - tauq: :type: complex :intent: output :dims: - MAX(1,nb) - taup: :type: complex :intent: output :dims: - MAX(1,nb) - x: :type: complex :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: complex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: MAX(1,m) ldy: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacgv000077500000000000000000000022341325016550400166210ustar00rootroot00000000000000--- :name: clacgv :md5sum: b798c93b96a1a5b91fa73ba3dcd76a1b :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacn2000077500000000000000000000055561325016550400165360ustar00rootroot00000000000000--- :name: clacn2 :md5sum: e82e391618650776158bd652bd776c82 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: complex :intent: workspace :dims: - n - x: :type: complex :intent: input/output :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacon000077500000000000000000000046121325016550400166230ustar00rootroot00000000000000--- :name: clacon :md5sum: a83f242544259a16370667c7f930d723 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: complex :intent: workspace :dims: - n - x: :type: complex :intent: input/output :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacp2000077500000000000000000000042031325016550400165240ustar00rootroot00000000000000--- :name: clacp2 :md5sum: 27b6c099766e4740d217c85767ea2a11 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacpy000077500000000000000000000042021325016550400166320ustar00rootroot00000000000000--- :name: clacpy :md5sum: b6d3093093de2f43162dc18940b3cfcf :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacrm000077500000000000000000000041461325016550400166270ustar00rootroot00000000000000--- :name: clacrm :md5sum: 1bf6ccc7ff0a4a97890dd67394c3dfe6 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clacrt000077500000000000000000000035471325016550400166420ustar00rootroot00000000000000--- :name: clacrt :md5sum: 6ca41ce11fcff052a8b28dc9c7778f27 :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: complex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: complex :intent: input - s: :type: complex :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cladiv000077500000000000000000000017441325016550400166310ustar00rootroot00000000000000--- :name: cladiv :md5sum: 3c908b32d86634d06c097310466421b6 :category: :function :type: complex :arguments: - x: :type: complex :intent: input - y: :type: complex :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claed0000077500000000000000000000073451325016550400165220ustar00rootroot00000000000000--- :name: claed0 :md5sum: 83b18987c9b3313733de29e1dea9bdad :category: :subroutine :arguments: - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: complex :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - 1 + 3*n + 2*n*LG(n) + 3*pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 6 + 6*n + 5*n*LG(n) - info: :type: integer :intent: output :substitutions: ldqs: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claed7000077500000000000000000000174411325016550400165270ustar00rootroot00000000000000--- :name: claed7 :md5sum: 4144e9f8c4eb810edf6ef201330922b3 :category: :subroutine :arguments: - n: :type: integer :intent: input - cutpnt: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: real :intent: input - indxq: :type: integer :intent: output :dims: - n - qstore: :type: real :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: real :intent: input :dims: - "2" - n*LG(n) - work: :type: complex :intent: workspace :dims: - qsiz*n - rwork: :type: real :intent: workspace :dims: - 3*n+2*qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/claed8000077500000000000000000000152331325016550400165250ustar00rootroot00000000000000--- :name: claed8 :md5sum: 09090f0f6ee43e9175bf724857ff705a :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - rho: :type: real :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: real :intent: input :dims: - n - dlamda: :type: real :intent: output :dims: - n - q2: :type: complex :intent: output :dims: - ldq2 - n - ldq2: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - indxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: real :intent: output :dims: - "2" - n - info: :type: integer :intent: output :substitutions: ldq2: MAX( 1, n ) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claein000077500000000000000000000062561325016550400166250ustar00rootroot00000000000000--- :name: claein :md5sum: 10958c9e44d2ecd0dada6eee846d037a :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: complex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: input - v: :type: complex :intent: input/output :dims: - n - b: :type: complex :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - n - eps3: :type: real :intent: input - smlnum: :type: real :intent: input - info: :type: integer :intent: output :substitutions: ldb: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claesy000077500000000000000000000047341325016550400166510ustar00rootroot00000000000000--- :name: claesy :md5sum: cda88734cca22f111cf3994c8552cfb4 :category: :subroutine :arguments: - a: :type: complex :intent: input - b: :type: complex :intent: input - c: :type: complex :intent: input - rt1: :type: complex :intent: output - rt2: :type: complex :intent: output - evscal: :type: complex :intent: output - cs1: :type: complex :intent: output - sn1: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claev2000077500000000000000000000046731325016550400165470ustar00rootroot00000000000000--- :name: claev2 :md5sum: c17a6c0ba6505716c01d705bebc81800 :category: :subroutine :arguments: - a: :type: complex :intent: input - b: :type: complex :intent: input - c: :type: complex :intent: input - rt1: :type: real :intent: output - rt2: :type: real :intent: output - cs1: :type: real :intent: output - sn1: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clag2z000077500000000000000000000035161325016550400165500ustar00rootroot00000000000000--- :name: clag2z :md5sum: 46933ce5b4f1eadd7bc7106884919faf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - sa: :type: complex :intent: input :dims: - ldsa - n - ldsa: :type: integer :intent: input - a: :type: doublecomplex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clags2000077500000000000000000000062511325016550400165400ustar00rootroot00000000000000--- :name: clags2 :md5sum: dd5ce497c6159dda6d9710975dc6d15a :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: real :intent: input - a2: :type: complex :intent: input - a3: :type: real :intent: input - b1: :type: real :intent: input - b2: :type: complex :intent: input - b3: :type: real :intent: input - csu: :type: real :intent: output - snu: :type: complex :intent: output - csv: :type: real :intent: output - snv: :type: complex :intent: output - csq: :type: real :intent: output - snq: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clagtm000077500000000000000000000060611325016550400166330ustar00rootroot00000000000000--- :name: clagtm :md5sum: 76bb9071a03ce8f5aeaa641ddf9532e8 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: real :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: real :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clahef000077500000000000000000000106541325016550400166110ustar00rootroot00000000000000--- :name: clahef :md5sum: 495b64a6cbdc181f0b2a8122b9805ff0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: complex :intent: workspace :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clahqr000077500000000000000000000133631325016550400166410ustar00rootroot00000000000000--- :name: clahqr :md5sum: d125b723dbd235592af2682105ae6ba2 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clahr2000077500000000000000000000115561325016550400165440ustar00rootroot00000000000000--- :name: clahr2 :md5sum: 830e928c511e3ec5d35e891b95ae225c :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MAX(1,nb) - t: :type: complex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: complex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clahrd000077500000000000000000000105461325016550400166240ustar00rootroot00000000000000--- :name: clahrd :md5sum: 6123a9d87b5a1b9590c8e1a49e30d6f8 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MAX(1,nb) - t: :type: complex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: complex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: MAX(1,n) ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claic1000077500000000000000000000052211325016550400165150ustar00rootroot00000000000000--- :name: claic1 :md5sum: 22926ad0c8db95eafc17cf2632e11865 :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: complex :intent: input :dims: - j - sest: :type: real :intent: input - w: :type: complex :intent: input :dims: - j - gamma: :type: complex :intent: input - sestpr: :type: real :intent: output - s: :type: complex :intent: output - c: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clals0000077500000000000000000000166731325016550400165540ustar00rootroot00000000000000--- :name: clals0 :md5sum: ad7ab4b461d9859a4b3030cba44206c0 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: complex :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: real :intent: input :dims: - ldgnum - "2" - difl: :type: real :intent: input :dims: - k - difr: :type: real :intent: input :dims: - ldgnum - "2" - z: :type: real :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: real :intent: input - s: :type: real :intent: input - rwork: :type: real :intent: workspace :dims: - k*(1+nrhs) + 2*nrhs - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clalsa000077500000000000000000000175131325016550400166270ustar00rootroot00000000000000--- :name: clalsa :md5sum: 363cb6c58961bef07799e856899db4f6 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: complex :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: real :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: real :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: real :intent: input :dims: - ldu - nlvl - difr: :type: real :intent: input :dims: - ldu - 2 * nlvl - z: :type: real :intent: input :dims: - ldu - nlvl - poles: :type: real :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: real :intent: input :dims: - ldu - 2 * nlvl - c: :type: real :intent: input :dims: - n - s: :type: real :intent: input :dims: - n - rwork: :type: real :intent: workspace :dims: - MAX(n,(smlsiz+1)*nrhs*3) - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clalsd000077500000000000000000000125351325016550400166310ustar00rootroot00000000000000--- :name: clalsd :md5sum: 67e6050323bb3b9ddcb04cc9b8ea807c :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - n * nrhs - rwork: :type: real :intent: workspace :dims: - 9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1 :extras: nlvl: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clangb000077500000000000000000000054661325016550400166220ustar00rootroot00000000000000--- :name: clangb :md5sum: 4671133f3e16efb8ebc9afc55c1fae56 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,lsame_(&norm,\"I\") ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clange000077500000000000000000000047071325016550400166220ustar00rootroot00000000000000--- :name: clange :md5sum: 6793322d76fa36f62a8b759167322ea6 :category: :function :type: real :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clangt000077500000000000000000000042511325016550400166330ustar00rootroot00000000000000--- :name: clangt :md5sum: 652ea6ab81e8f71ce9bebc5bc9493bb5 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clanhb000077500000000000000000000064051325016550400166150ustar00rootroot00000000000000--- :name: clanhb :md5sum: f47750f12cb222d8f12ee2c177479928 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clanhe000077500000000000000000000063071325016550400166210ustar00rootroot00000000000000--- :name: clanhe :md5sum: 35c5d3fb031ab7f142837a679fb0d090 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"o\")) ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clanhf000077500000000000000000000200311325016550400166100ustar00rootroot00000000000000--- :name: clanhf :md5sum: 88dd9937813f707862d82f94478d3e58 :category: :function :type: real :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - lwork :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clanhp000077500000000000000000000056711325016550400166370ustar00rootroot00000000000000--- :name: clanhp :md5sum: 9dca827973764d6308604a8dd70a8e52 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"O\")) ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clanhs000077500000000000000000000045261325016550400166400ustar00rootroot00000000000000--- :name: clanhs :md5sum: 7cf1a1d1a95e15c62f33d712a3f376be :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clanht000077500000000000000000000040001325016550400166240ustar00rootroot00000000000000--- :name: clanht :md5sum: c658a5158529cfe7a4c7c521584dcd71 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clansb000077500000000000000000000062441325016550400166310ustar00rootroot00000000000000--- :name: clansb :md5sum: e61754eafe3b5e1bdf794923a4ad9977 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clansp000077500000000000000000000054651325016550400166530ustar00rootroot00000000000000--- :name: clansp :md5sum: 140cc467da7a57d49c7fb0014ea4ecc1 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"O\")) ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clansy000077500000000000000000000061241325016550400166550ustar00rootroot00000000000000--- :name: clansy :md5sum: 9e26445e2edd83a8a270cac207025f26 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"o\")) ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clantb000077500000000000000000000070461325016550400166330ustar00rootroot00000000000000--- :name: clantb :md5sum: b67405c765473479f482587ff2fd0f79 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,lsame_(&norm,\"I\") ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clantp000077500000000000000000000061361325016550400166500ustar00rootroot00000000000000--- :name: clantp :md5sum: dbd82e1acf27b336626c0bbbfee9eec8 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clantr000077500000000000000000000072601325016550400166510ustar00rootroot00000000000000--- :name: clantr :md5sum: 2952a019c52f6bc7681a557329258545 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clapll000077500000000000000000000035511325016550400166340ustar00rootroot00000000000000--- :name: clapll :md5sum: bc1696c79251fc14dc4c23739749cff4 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clapmr000077500000000000000000000040111325016550400166330ustar00rootroot00000000000000--- :name: clapmr :md5sum: 4d207b45c2fb96e99248c500f5cadba8 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clapmt000077500000000000000000000040141325016550400166400ustar00rootroot00000000000000--- :name: clapmt :md5sum: 95fff3ce7e61182829396a0511c231f4 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqgb000077500000000000000000000073171325016550400166220ustar00rootroot00000000000000--- :name: claqgb :md5sum: 3949a6ac3870026b07ce26c34aa20e54 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqge000077500000000000000000000061231325016550400166170ustar00rootroot00000000000000--- :name: claqge :md5sum: 71062e5276a246007a7f507402217ad2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqhb000077500000000000000000000063621325016550400166220ustar00rootroot00000000000000--- :name: claqhb :md5sum: 3c63a8f4036750b8735047ff5e8b0f0a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqhe000077500000000000000000000057521325016550400166270ustar00rootroot00000000000000--- :name: claqhe :md5sum: 85061ecb19020970fc9555db00b1b596 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqhp000077500000000000000000000053171325016550400166370ustar00rootroot00000000000000--- :name: claqhp :md5sum: a481d769a64275943f73dbe515a1ebf0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqp2000077500000000000000000000066501325016550400165520ustar00rootroot00000000000000--- :name: claqp2 :md5sum: 44ab7cf5adb154df3f069f835f338c36 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - MIN(m,n) - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - work: :type: complex :intent: workspace :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqps000077500000000000000000000101151325016550400166420ustar00rootroot00000000000000--- :name: claqps :md5sum: d435df2cf720a3491ba886138dbbe026 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - kb - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - auxv: :type: complex :intent: input/output :dims: - nb - f: :type: complex :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqr0000077500000000000000000000173631325016550400165550ustar00rootroot00000000000000--- :name: claqr0 :md5sum: 17110405cb2df6f5f3833a30a4a05ba5 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqr1000077500000000000000000000035231325016550400165470ustar00rootroot00000000000000--- :name: claqr1 :md5sum: 3f19c2453a865a3b2236f6174de113ff :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: complex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - s1: :type: complex :intent: input - s2: :type: complex :intent: input - v: :type: complex :intent: output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqr2000077500000000000000000000177231325016550400165570ustar00rootroot00000000000000--- :name: claqr2 :md5sum: 59b391f379b9ee57f3b536ba3712e7be :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: complex :intent: output :dims: - MAX(1,kbot) - v: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqr3000077500000000000000000000173651325016550400165620ustar00rootroot00000000000000--- :name: claqr3 :md5sum: f6a7a83a5d8a4a26881150044fdfd443 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: complex :intent: output :dims: - MAX(1,kbot) - v: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqr4000077500000000000000000000173631325016550400165610ustar00rootroot00000000000000--- :name: claqr4 :md5sum: 234329047676594dccc0a2de8eb860f7 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqr5000077500000000000000000000161711325016550400165560ustar00rootroot00000000000000--- :name: claqr5 :md5sum: 6054ea0e340c303fed500141047341cc :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - s: :type: complex :intent: input/output :dims: - nshfts - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: complex :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: complex :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: complex :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: complex :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqsb000077500000000000000000000063571325016550400166410ustar00rootroot00000000000000--- :name: claqsb :md5sum: f2a38c2dabc747d75a627865a1f6678f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqsp000077500000000000000000000053171325016550400166520ustar00rootroot00000000000000--- :name: claqsp :md5sum: 8848a8c7da22b13fd5e2a4b1707cf25c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claqsy000077500000000000000000000057521325016550400166660ustar00rootroot00000000000000--- :name: claqsy :md5sum: cda09f78eb86852e56f73b7cca3221cf :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clar1v000077500000000000000000000145061325016550400165570ustar00rootroot00000000000000--- :name: clar1v :md5sum: 476c7fc59e63411f4a380b0ca17e4c25 :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: real :intent: input - d: :type: real :intent: input :dims: - n - l: :type: real :intent: input :dims: - n-1 - ld: :type: real :intent: input :dims: - n-1 - lld: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - gaptol: :type: real :intent: input - z: :type: complex :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: real :intent: output - mingma: :type: real :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: real :intent: output - resid: :type: real :intent: output - rqcorr: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clar2v000077500000000000000000000051541325016550400165570ustar00rootroot00000000000000--- :name: clar2v :md5sum: 7ed20259419e6c0e94185c5273a1f5b6 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - z: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: complex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarcm000077500000000000000000000041431325016550400166240ustar00rootroot00000000000000--- :name: clarcm :md5sum: 1b2fff25bb662279ca1999d0a231aa4a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarf000077500000000000000000000051501325016550400164510ustar00rootroot00000000000000--- :name: clarf :md5sum: 7cf32c88d2dc45466c3c3062072fb5bb :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: complex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: complex :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarfb000077500000000000000000000076361325016550400166260ustar00rootroot00000000000000--- :name: clarfb :md5sum: 297dbf123408181db136925cb1ae5c61 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: complex :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: complex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/clarfg000077500000000000000000000037511325016550400166250ustar00rootroot00000000000000--- :name: clarfg :md5sum: b7684e6877d9b4630730f6ad023dcaf1 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: complex :intent: input/output - x: :type: complex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarfgp000077500000000000000000000036661325016550400170120ustar00rootroot00000000000000--- :name: clarfgp :md5sum: 5d0def6a130365d7dc2054a64b3ca16a :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: complex :intent: input/output - x: :type: complex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarft000077500000000000000000000107241325016550400166400ustar00rootroot00000000000000--- :name: clarft :md5sum: 74b95dc223df4ad5e87ce0c8b73b032b :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - t: :type: complex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarfx000077500000000000000000000045741325016550400166520ustar00rootroot00000000000000--- :name: clarfx :md5sum: 9e263a35974f11168c2a951af14c6ac1 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: complex :intent: input :dims: - m - tau: :type: complex :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clargv000077500000000000000000000050101325016550400166330ustar00rootroot00000000000000--- :name: clargv :md5sum: 494d5c7b6b8663202a721836295fac6e :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarnv000077500000000000000000000037101325016550400166470ustar00rootroot00000000000000--- :name: clarnv :md5sum: d8a94840fe9945fe9d176d472042aa2b :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: complex :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarrv000077500000000000000000000221421325016550400166530ustar00rootroot00000000000000--- :name: clarrv :md5sum: 247eb83eb2fa79b6048985eb11384e6f :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - d: :type: real :intent: input/output :dims: - n - l: :type: real :intent: input/output :dims: - n - pivmin: :type: real :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: real :intent: input - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - w: :type: real :intent: input/output :dims: - n - werr: :type: real :intent: input/output :dims: - n - wgap: :type: real :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: real :intent: input :dims: - 2*n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " 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 split.) 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 occurred 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" ruby-lapack-1.8.1/dev/defs/clarscl2000077500000000000000000000030131325016550400170630ustar00rootroot00000000000000--- :name: clarscl2 :md5sum: 2dba756f9cc2571be842927d2cd02442 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clartg000077500000000000000000000034271325016550400166430ustar00rootroot00000000000000--- :name: clartg :md5sum: aa8c43ad25ac528306b6dc6dd6d172f6 :category: :subroutine :arguments: - f: :type: complex :intent: input - g: :type: complex :intent: input - cs: :type: real :intent: output - sn: :type: complex :intent: output - r: :type: complex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clartv000077500000000000000000000042351325016550400166600ustar00rootroot00000000000000--- :name: clartv :md5sum: 66385b4b24372bfb5f9f2668f63301e3 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: complex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarz000077500000000000000000000060561325016550400165030ustar00rootroot00000000000000--- :name: clarz :md5sum: 0f5559fe28e5257781743a106558e54f :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: complex :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: complex :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clarzb000077500000000000000000000103221325016550400166340ustar00rootroot00000000000000--- :name: clarzb :md5sum: b1a6ab49c9ee4c3c63094d8f6e6eb92a :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: complex :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: complex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/clarzt000077500000000000000000000122541325016550400166640ustar00rootroot00000000000000--- :name: clarzt :md5sum: 99197ece47e417c570eb4b4a4b1a2418 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - t: :type: complex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clascl000077500000000000000000000063261325016550400166310ustar00rootroot00000000000000--- :name: clascl :md5sum: fce65101e2bd6b47b1be23e27767bac2 :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: real :intent: input - cto: :type: real :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clascl2000077500000000000000000000027671325016550400167200ustar00rootroot00000000000000--- :name: clascl2 :md5sum: 9b6d7c19706b050d8089911e3fd99ddc :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claset000077500000000000000000000043561325016550400166440ustar00rootroot00000000000000--- :name: claset :md5sum: 064dfdfbe3ff9686c339a8059099f40d :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - beta: :type: complex :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clasr000077500000000000000000000140071325016550400164670ustar00rootroot00000000000000--- :name: clasr :md5sum: 9edeb6dbb98dd9c3e28985b4bc103c42 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: real :intent: input :dims: - m-1 - s: :type: real :intent: input :dims: - m-1 - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/classq000077500000000000000000000041551325016550400166540ustar00rootroot00000000000000--- :name: classq :md5sum: 98b03e0f8741f340e1c75a898eb65b7e :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: real :intent: input/output - sumsq: :type: real :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/claswp000077500000000000000000000044761325016550400166650ustar00rootroot00000000000000--- :name: claswp :md5sum: 4612b48da9d86f8d302ad0a932b6e32d :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clasyf000077500000000000000000000106421325016550400166450ustar00rootroot00000000000000--- :name: clasyf :md5sum: 4b7a69b4acd8a223ada4d2f51b1e12a2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: complex :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clatbs000077500000000000000000000170201325016550400166310ustar00rootroot00000000000000--- :name: clatbs :md5sum: 62c760c1f0e34668fbf1dfcec980d0f4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clatdf000077500000000000000000000115331325016550400166210ustar00rootroot00000000000000--- :name: clatdf :md5sum: 5c926a59b991b5455a3094fe676dfba8 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: complex :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: complex :intent: input/output :dims: - n - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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 chosen 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" ruby-lapack-1.8.1/dev/defs/clatps000077500000000000000000000163011325016550400166500ustar00rootroot00000000000000--- :name: clatps :md5sum: d713535a97fe8819f48baf9545b24b97 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - x: :type: complex :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clatrd000077500000000000000000000140211325016550400166300ustar00rootroot00000000000000--- :name: clatrd :md5sum: ad2e74bcec91b1bccbee75fb9f8dcbe7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - w: :type: complex :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clatrs000077500000000000000000000170771325016550400166650ustar00rootroot00000000000000--- :name: clatrs :md5sum: 7acf429b0c580f6619388ac433e3add1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clatrz000077500000000000000000000066031325016550400166650ustar00rootroot00000000000000--- :name: clatrz :md5sum: f96426c31ee39ce138c0da717ed0c0d5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - m - work: :type: complex :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clatzm000077500000000000000000000071751325016550400166650ustar00rootroot00000000000000--- :name: clatzm :md5sum: 31aadd9c9169ced60aa53e18dda4843a :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: complex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: complex :intent: input - c1: :type: complex :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: complex :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clauu2000077500000000000000000000041341325016550400165560ustar00rootroot00000000000000--- :name: clauu2 :md5sum: 986c1fc35dfe718d18770f0d9c923763 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/clauum000077500000000000000000000041321325016550400166470ustar00rootroot00000000000000--- :name: clauum :md5sum: f581ea1c2a8bf3f26404843289f3189c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbcon000077500000000000000000000057571325016550400166430ustar00rootroot00000000000000--- :name: cpbcon :md5sum: f2a838373a459acebb9c8d2885c52046 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbequ000077500000000000000000000062021325016550400166400ustar00rootroot00000000000000--- :name: cpbequ :md5sum: 23fe815105e015e77f5f060fae9224b5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbrfs000077500000000000000000000117471325016550400166520ustar00rootroot00000000000000--- :name: cpbrfs :md5sum: 48c158d45998746437808d4354b35cc6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbstf000077500000000000000000000077511325016550400166540ustar00rootroot00000000000000--- :name: cpbstf :md5sum: dd6e5004dfa546d7f8f70d62b37358f4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbsv000077500000000000000000000114051325016550400164770ustar00rootroot00000000000000--- :name: cpbsv :md5sum: 509caf333be99485328c142a494723c9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbsvx000077500000000000000000000274451325016550400167020ustar00rootroot00000000000000--- :name: cpbsvx :md5sum: dd6dc051e36b6752af3418cbf8133450 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbtf2000077500000000000000000000071271325016550400165500ustar00rootroot00000000000000--- :name: cpbtf2 :md5sum: 9dc08eed5d77e0abfd14e60815cef7a6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbtrf000077500000000000000000000067521325016550400166530ustar00rootroot00000000000000--- :name: cpbtrf :md5sum: 366ae9ae1c36282a8bfb40561c1d99cf :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpbtrs000077500000000000000000000060761325016550400166670ustar00rootroot00000000000000--- :name: cpbtrs :md5sum: a372d285f8e1289f9739e11ea3d0058e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpftrf000077500000000000000000000157141325016550400166550ustar00rootroot00000000000000--- :name: cpftrf :md5sum: c3098b2d776c64593a40443315a45dfd :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpftri000077500000000000000000000152211325016550400166510ustar00rootroot00000000000000--- :name: cpftri :md5sum: 628346e3f91d7dfc0bb02666b752fd84 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpftrs000077500000000000000000000146701325016550400166720ustar00rootroot00000000000000--- :name: cpftrs :md5sum: ccd62c87dcf766b816524a7c639bb28b :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpocon000077500000000000000000000046471325016550400166550ustar00rootroot00000000000000--- :name: cpocon :md5sum: 0582d260e85edffd69e2b598d76d7f02 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpoequ000077500000000000000000000047641325016550400166700ustar00rootroot00000000000000--- :name: cpoequ :md5sum: 682ec464ccfd2c44926755219357888c :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpoequb000077500000000000000000000047671325016550400170350ustar00rootroot00000000000000--- :name: cpoequb :md5sum: f0abc0761ce91060ba240df4dd323aa2 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cporfs000077500000000000000000000114011325016550400166520ustar00rootroot00000000000000--- :name: cporfs :md5sum: f9b7b261f3c53ee94e6f500ba8bf61b7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cporfsx000077500000000000000000000366211325016550400170550ustar00rootroot00000000000000--- :name: cporfsx :md5sum: db2e61f6b964b4e653e41a1a3252fdb2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cposv000077500000000000000000000070501325016550400165150ustar00rootroot00000000000000--- :name: cposv :md5sum: 1485e74677b64f3f220c975c8c0afcb6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cposvx000077500000000000000000000255041325016550400167110ustar00rootroot00000000000000--- :name: cposvx :md5sum: 5047940aaa72c0b2ca58d57ec4923985 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cposvxx000077500000000000000000000505501325016550400171000ustar00rootroot00000000000000--- :name: cposvxx :md5sum: 882ffc7988c6739b23858fcef7731bed :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/cpotf2000077500000000000000000000047131325016550400165630ustar00rootroot00000000000000--- :name: cpotf2 :md5sum: a7c491fac2d61e6bc2983fde569beb7d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpotrf000077500000000000000000000045641325016550400166670ustar00rootroot00000000000000--- :name: cpotrf :md5sum: e578ccb7a6444634bdf1983eb5cf16b9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpotri000077500000000000000000000041261325016550400166640ustar00rootroot00000000000000--- :name: cpotri :md5sum: 9ceb1cdb87edadbd814f66025a60044e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpotrs000077500000000000000000000041751325016550400167020ustar00rootroot00000000000000--- :name: cpotrs :md5sum: 8d3cc3dae23907090d62f41e1d1f4629 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cppcon000077500000000000000000000050661325016550400166520ustar00rootroot00000000000000--- :name: cppcon :md5sum: c3caf11aabcf2b12028393d086f0a544 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cppequ000077500000000000000000000053531325016550400166640ustar00rootroot00000000000000--- :name: cppequ :md5sum: 1f019efc434c1da34e8b0c380a3dbce8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpprfs000077500000000000000000000106561325016550400166660ustar00rootroot00000000000000--- :name: cpprfs :md5sum: 8a43d4e4a0ca70bf33d98b675e1af06b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cppsv000077500000000000000000000075531325016550400165260ustar00rootroot00000000000000--- :name: cppsv :md5sum: 263bad3d932191350716a728abd9f879 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cppsvx000077500000000000000000000257161325016550400167170ustar00rootroot00000000000000--- :name: cppsvx :md5sum: 7c5c075a3757dacd30b5886053520e39 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - afp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpptrf000077500000000000000000000051601325016550400166610ustar00rootroot00000000000000--- :name: cpptrf :md5sum: 0535cb122052f3009f316946a454aecc :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpptri000077500000000000000000000036351325016550400166710ustar00rootroot00000000000000--- :name: cpptri :md5sum: 8720a8073e7c8a28a6d01f6ad7d603d2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpptrs000077500000000000000000000051721325016550400167010ustar00rootroot00000000000000--- :name: cpptrs :md5sum: a5d4c77afe8b8f87c48b32cd50b42f9e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpstf2000077500000000000000000000067421325016550400165730ustar00rootroot00000000000000--- :name: cpstf2 :md5sum: a8e79b54d21b622910982637f54f9b0c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpstrf000077500000000000000000000067401325016550400166710ustar00rootroot00000000000000--- :name: cpstrf :md5sum: 6db062af9f26bd93641c108b59166894 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cptcon000077500000000000000000000047071325016550400166570ustar00rootroot00000000000000--- :name: cptcon :md5sum: f44569b6ef35f71a7ce889e59b7f2950 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - anorm: :type: real :intent: input - rcond: :type: real :intent: output - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpteqr000077500000000000000000000103661325016550400166650ustar00rootroot00000000000000--- :name: cpteqr :md5sum: d6ff24d6a8c210f3d0d24cbe9a55d908 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cptrfs000077500000000000000000000111501325016550400166600ustar00rootroot00000000000000--- :name: cptrfs :md5sum: 9b5bef723bf83861b13e566ffe866e75 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - df: :type: real :intent: input :dims: - n - ef: :type: complex :intent: input :dims: - n-1 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cptsv000077500000000000000000000056551325016550400165330ustar00rootroot00000000000000--- :name: cptsv :md5sum: 51cb8a965fde05d2a1884508d277624f :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: complex :intent: input/output :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cptsvx000077500000000000000000000164511325016550400167170ustar00rootroot00000000000000--- :name: cptsvx :md5sum: a5c06f21616bb02edc1995a65814fd71 :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - df: :type: real :intent: input/output :dims: - n - ef: :type: complex :intent: input/output :dims: - n-1 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpttrf000077500000000000000000000037311325016550400166670ustar00rootroot00000000000000--- :name: cpttrf :md5sum: 3c95d303d2eee9086e51e0c7a963a9a6 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: complex :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cpttrs000077500000000000000000000063201325016550400167010ustar00rootroot00000000000000--- :name: cpttrs :md5sum: 13a14e1496854b5687986f2a43e1fdbe :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cptts2000077500000000000000000000055231325016550400166050ustar00rootroot00000000000000--- :name: cptts2 :md5sum: 681017bf4848ba56ba74ad522dbff08c :category: :subroutine :arguments: - iuplo: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/crot000077500000000000000000000036731325016550400163410ustar00rootroot00000000000000--- :name: crot :md5sum: 5c7ea320d6a9412ddf95fc7a6f674517 :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: complex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: real :intent: input - s: :type: complex :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cspcon000077500000000000000000000050351325016550400166510ustar00rootroot00000000000000--- :name: cspcon :md5sum: 2693ebd7b761444b3518da41dddce980 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cspmv000077500000000000000000000077551325016550400165270ustar00rootroot00000000000000--- :name: cspmv :md5sum: 247e190a3b417303369ffe78ead9f23c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - ap: :type: complex :intent: input :dims: - ldap - x: :type: complex :intent: input :dims: - 1 + (n-1)*abs(incx) - incx: :type: integer :intent: input - beta: :type: complex :intent: input - y: :type: complex :intent: input/output :dims: - 1 + (n-1)*abs(incy) - incy: :type: integer :intent: input :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\ *\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" ruby-lapack-1.8.1/dev/defs/cspr000077500000000000000000000067241325016550400163410ustar00rootroot00000000000000--- :name: cspr :md5sum: d07736c23393e9ea356860b4e3d8a14b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ( n*( n + 1 ) )/2 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csprfs000077500000000000000000000113421325016550400166620ustar00rootroot00000000000000--- :name: csprfs :md5sum: 3ec422cb25319a32a48c132c4cf128f4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cspsv000077500000000000000000000115311325016550400165200ustar00rootroot00000000000000--- :name: cspsv :md5sum: 8afbd7ff5fb61d346b159c2fd129c50f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cspsvx000077500000000000000000000225111325016550400167100ustar00rootroot00000000000000--- :name: cspsvx :md5sum: 301c107c780567b960fdeac5c4653ffd :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csptrf000077500000000000000000000115571325016550400166730ustar00rootroot00000000000000--- :name: csptrf :md5sum: 4c99db07d0e28d8dca31885d59d58116 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csptri000077500000000000000000000047111325016550400166700ustar00rootroot00000000000000--- :name: csptri :md5sum: 11624b714c13369e07cbd0797efbed99 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csptrs000077500000000000000000000046451325016550400167100ustar00rootroot00000000000000--- :name: csptrs :md5sum: f8b60d66389c0af1a3e55795b48dcc6f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csrscl000077500000000000000000000025761325016550400166640ustar00rootroot00000000000000--- :name: csrscl :md5sum: 2d5e6bc7ca9f51ad75c919ce98a07627 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: real :intent: input - sx: :type: complex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cstedc000077500000000000000000000173221325016550400166330ustar00rootroot00000000000000--- :name: cstedc :md5sum: 0cb301e3ca0d09d7acb4ab12140db0e3 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cstegr000077500000000000000000000205541325016550400166560ustar00rootroot00000000000000--- :name: cstegr :md5sum: d6dab7dc05d3eff31201f84ab530e5d5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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 compatibility 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" ruby-lapack-1.8.1/dev/defs/cstein000077500000000000000000000117701325016550400166540ustar00rootroot00000000000000--- :name: cstein :md5sum: 738c45b1cce1bfa88f60e473bd396273 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: real :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: complex :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cstemr000077500000000000000000000312141325016550400166570ustar00rootroot00000000000000--- :name: cstemr :md5sum: 67d185e1ab47a23685d6c651ae0c225b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csteqr000077500000000000000000000071471325016550400166730ustar00rootroot00000000000000--- :name: csteqr :md5sum: 278eb31a7052cf9df5ea2f545eedabca :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csycon000077500000000000000000000051761325016550400166700ustar00rootroot00000000000000--- :name: csycon :md5sum: 800f12535dbc26a63c273077b3a6fb4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csyconv000077500000000000000000000051051325016550400170460ustar00rootroot00000000000000--- :name: csyconv :md5sum: e73f59e4a1733ca5d74167eeee971dba :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csyequb000077500000000000000000000064301325016550400170370ustar00rootroot00000000000000--- :name: csyequb :md5sum: 6f43922d6b26e70d1e0277e86441bb24 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csymv000077500000000000000000000100621325016550400165210ustar00rootroot00000000000000--- :name: csymv :md5sum: 28f107317aaa4462049422975308edee :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: complex :intent: input - y: :type: complex :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csyr000077500000000000000000000066641325016550400163550ustar00rootroot00000000000000--- :name: csyr :md5sum: 0d882c1ac101190a904cd313b2ad84cd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csyrfs000077500000000000000000000121501325016550400166710ustar00rootroot00000000000000--- :name: csyrfs :md5sum: 4970ead7255fb16d7d98d6b6286b9d12 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csyrfsx000077500000000000000000000373361325016550400170760ustar00rootroot00000000000000--- :name: csyrfsx :md5sum: 5751d1c98e030d16ad5c84317087f0a3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csysv000077500000000000000000000127421325016550400165360ustar00rootroot00000000000000--- :name: csysv :md5sum: eb3a9b2a1e9a499c6394d402697b0f15 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csysvx000077500000000000000000000234011325016550400167200ustar00rootroot00000000000000--- :name: csysvx :md5sum: 77314dc5b8cd439895289aa101e91eb2 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csysvxx000077500000000000000000000515431325016550400171200ustar00rootroot00000000000000--- :name: csysvxx :md5sum: cc892e69a3d21b7e853bcf241519ec7c :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/csyswapr000077500000000000000000000043421325016550400172370ustar00rootroot00000000000000--- :name: csyswapr :md5sum: e53b159491b12c5dd923b2795134aff2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytf2000077500000000000000000000127501325016550400166000ustar00rootroot00000000000000--- :name: csytf2 :md5sum: a866e0c8cb88e0e0931d644bd4f44e78 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytrf000077500000000000000000000144721325016550400167030ustar00rootroot00000000000000--- :name: csytrf :md5sum: dcc01e01acbde525a3b24fce6f4fc7b1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytri000077500000000000000000000050611325016550400167000ustar00rootroot00000000000000--- :name: csytri :md5sum: aa4c75a051e607ba62145c33dc81a023 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytri2000077500000000000000000000073431325016550400167670ustar00rootroot00000000000000--- :name: csytri2 :md5sum: b6d9a32ccfff551e13aeac00195defaa :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" nb: ilaenv_(&c__1, "CSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytri2x000077500000000000000000000052731325016550400171570ustar00rootroot00000000000000--- :name: csytri2x :md5sum: a3d45c60190155762686eac6e370ef80 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytrs000077500000000000000000000047661325016550400167250ustar00rootroot00000000000000--- :name: csytrs :md5sum: 784ed608d5930bb4507bf2cf968d77e7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/csytrs2000077500000000000000000000052401325016550400167730ustar00rootroot00000000000000--- :name: csytrs2 :md5sum: ede0b063319e696fdadf1357131d6a98 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctbcon000077500000000000000000000062511325016550400166350ustar00rootroot00000000000000--- :name: ctbcon :md5sum: 5d8bdcb99cde893c680cec51fda218c8 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctbrfs000077500000000000000000000116541325016550400166530ustar00rootroot00000000000000--- :name: ctbrfs :md5sum: 7c86c62620f2a6d4354d70f9e0b25b2c :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctbtrs000077500000000000000000000066611325016550400166730ustar00rootroot00000000000000--- :name: ctbtrs :md5sum: c9693dc332b90354ae799914b6e7d411 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctfsm000077500000000000000000000225031325016550400164770ustar00rootroot00000000000000--- :name: ctfsm :md5sum: d21aad1c42cd0f99fe857823611311a5 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - a: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctftri000077500000000000000000000154611325016550400166630ustar00rootroot00000000000000--- :name: ctftri :md5sum: a5ecbd1b6b84ce5c5fe2fc099ead92f8 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctfttp000077500000000000000000000141551325016550400166730ustar00rootroot00000000000000--- :name: ctfttp :md5sum: 5f4fc9970b485e991ce8f01eb38da11d :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: complex :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: complex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctfttr000077500000000000000000000147101325016550400166720ustar00rootroot00000000000000--- :name: ctfttr :md5sum: 66395551e389cab666a024291681e258 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: complex :intent: input :dims: - ldarf - a: :type: complex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldarf*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgevc000077500000000000000000000150401325016550400166340ustar00rootroot00000000000000--- :name: ctgevc :md5sum: 34fff5554b8b02ba108f616b7c23fbde :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: complex :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: complex :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: complex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgex2000077500000000000000000000116441325016550400165630ustar00rootroot00000000000000--- :name: ctgex2 :md5sum: 291e324cd2dab391083a4d6d15ee8c8d :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - "wantq ? ldq : 0" - "wantq ? n : 0" - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - "wantq ? ldz : 0" - "wantq ? n : 0" - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgexc000077500000000000000000000137171325016550400166470ustar00rootroot00000000000000--- :name: ctgexc :md5sum: 28615b111bd89941edff51027b6ac193 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgsen000077500000000000000000000373631325016550400166600ustar00rootroot00000000000000--- :name: ctgsen :md5sum: 611f676b24131fa01861ff97339e1db5 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: real :intent: output - pr: :type: real :intent: output - dif: :type: real :intent: output :dims: - "2" - work: :type: complex :intent: output :dims: - 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: - 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 :substitutions: {} :fortran_help: " 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\t (output) REAL\n\ * PR\t (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" ruby-lapack-1.8.1/dev/defs/ctgsja000077500000000000000000000256461325016550400166510ustar00rootroot00000000000000--- :name: ctgsja :md5sum: 694244b545f1c3526c7c564611a2e147 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: complex :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgsna000077500000000000000000000236311325016550400166450ustar00rootroot00000000000000--- :name: ctgsna :md5sum: e17266654acf82fe202bcab72adebbe1 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: complex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - dif: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n+2" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgsy2000077500000000000000000000174301325016550400166010ustar00rootroot00000000000000--- :name: ctgsy2 :md5sum: fd16bf64f0e7ab12a71f285b2f8febc0 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: complex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: complex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: complex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctgsyl000077500000000000000000000224201325016550400166660ustar00rootroot00000000000000--- :name: ctgsyl :md5sum: 353e93545b3d9d5928409ecbfb8864c2 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: complex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: complex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: complex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - dif: :type: real :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctpcon000077500000000000000000000054551325016550400166600ustar00rootroot00000000000000--- :name: ctpcon :md5sum: 23dc10d29cb244e7abee807ca79e6757 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctprfs000077500000000000000000000110341325016550400166610ustar00rootroot00000000000000--- :name: ctprfs :md5sum: bd37980bab10e66ded4499fe3f0267e2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctptri000077500000000000000000000052061325016550400166710ustar00rootroot00000000000000--- :name: ctptri :md5sum: 237746a719623b18e0c7de528f689bca :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctptrs000077500000000000000000000057041325016550400167060ustar00rootroot00000000000000--- :name: ctptrs :md5sum: e9791f6e0e5d2ec2337a6d090c7ae16b :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctpttf000077500000000000000000000141741325016550400166740ustar00rootroot00000000000000--- :name: ctpttf :md5sum: a3138578f1484902c662e2e58b35bf01 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: complex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctpttr000077500000000000000000000044301325016550400167020ustar00rootroot00000000000000--- :name: ctpttr :md5sum: cff59730a94a7f4cea094f49c60d4f70 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - a: :type: complex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrcon000077500000000000000000000060661325016550400166610ustar00rootroot00000000000000--- :name: ctrcon :md5sum: f981f46545d070fd6eaeba4cc354de5f :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrevc000077500000000000000000000146611325016550400166570ustar00rootroot00000000000000--- :name: ctrevc :md5sum: d514272127683844e93020ff209cd3db :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: complex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrexc000077500000000000000000000062041325016550400166530ustar00rootroot00000000000000--- :name: ctrexc :md5sum: 98fce909e94f4aeceac927f4fb0dce87 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrrfs000077500000000000000000000114711325016550400166700ustar00rootroot00000000000000--- :name: ctrrfs :md5sum: 323b422cdf688d84bac937d4cd0110dd :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrsen000077500000000000000000000207471325016550400166710ustar00rootroot00000000000000--- :name: ctrsen :md5sum: d2b5291e456ad12fb0adea66a05d53de :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: real :intent: output - sep: :type: real :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrsna000077500000000000000000000166411325016550400166630ustar00rootroot00000000000000--- :name: ctrsna :md5sum: e91cc890d0ea7dbba10a9adc422212aa :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: complex :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: complex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - sep: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrsyl000077500000000000000000000070421325016550400167040ustar00rootroot00000000000000--- :name: ctrsyl :md5sum: 197d88da50e387a8b9e1087a4832e33a :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrti2000077500000000000000000000045441325016550400165770ustar00rootroot00000000000000--- :name: ctrti2 :md5sum: 540ce02ac93c8ae2c4c1845d53530736 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrtri000077500000000000000000000045671325016550400167040ustar00rootroot00000000000000--- :name: ctrtri :md5sum: fb01fa3296c8462888d1c442fee9ca77 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrtrs000077500000000000000000000065001325016550400167030ustar00rootroot00000000000000--- :name: ctrtrs :md5sum: f4b2c572df1427345c348b89b7533172 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrttf000077500000000000000000000146641325016550400167020ustar00rootroot00000000000000--- :name: ctrttf :md5sum: 6a5c6f7d589892c220e1674bad5372e3 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctrttp000077500000000000000000000043571325016550400167120ustar00rootroot00000000000000--- :name: ctrttp :md5sum: ceec2a9ae63238ae23ddc810916fa9fb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: complex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctzrqf000077500000000000000000000064241325016550400167000ustar00rootroot00000000000000--- :name: ctzrqf :md5sum: 073bf9d20f3eef05da18d6ba71f465f8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ctzrzf000077500000000000000000000101631325016550400167040ustar00rootroot00000000000000--- :name: ctzrzf :md5sum: 0236521a4c727d201e0d3d1786f9f82b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - m - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunbdb000077500000000000000000000214061325016550400166210ustar00rootroot00000000000000--- :name: cunbdb :md5sum: f3d37f59c9a21d3cf112e287fa50b474 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: complex :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: complex :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: complex :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: complex :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - q - phi: :type: real :intent: output :dims: - q-1 - taup1: :type: complex :intent: output :dims: - p - taup2: :type: complex :intent: output :dims: - m-p - tauq1: :type: complex :intent: output :dims: - q - tauq2: :type: complex :intent: output :dims: - m-q - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cuncsd000077500000000000000000000203621325016550400166430ustar00rootroot00000000000000--- :name: cuncsd :md5sum: d8aa106ce46e78717abfa350e82b3bf7 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: complex :intent: input :dims: - p - q - ldx11: :type: integer :intent: input - x12: :type: complex :intent: input :dims: - p - m-q - ldx12: :type: integer :intent: input - x21: :type: complex :intent: input :dims: - p - q - ldx21: :type: integer :intent: input - x22: :type: complex :intent: input :dims: - p - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: complex :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: complex :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: complex :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: complex :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" 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 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cung2l000077500000000000000000000044341325016550400165600ustar00rootroot00000000000000--- :name: cung2l :md5sum: 47a3cd3791dbf603dc72bd8465be2b51 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cung2r000077500000000000000000000044301325016550400165620ustar00rootroot00000000000000--- :name: cung2r :md5sum: fb8fb5bf1556d2bed7db5cf3c96185c5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungbr000077500000000000000000000104761325016550400166510ustar00rootroot00000000000000--- :name: cungbr :md5sum: ebdc563d42e1aaeb9f17a8b5cd146e40 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - MIN(m,k) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunghr000077500000000000000000000056131325016550400166540ustar00rootroot00000000000000--- :name: cunghr :md5sum: acce247a28646ccc2aef73082933dd45 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungl2000077500000000000000000000044001325016550400165510ustar00rootroot00000000000000--- :name: cungl2 :md5sum: 930c4f7265868e01524d9b4e01ef32e5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunglq000077500000000000000000000056731325016550400166650ustar00rootroot00000000000000--- :name: cunglq :md5sum: d4f3daf8bd53210a78b538ace0bd1b56 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungql000077500000000000000000000057341325016550400166630ustar00rootroot00000000000000--- :name: cungql :md5sum: c47a9b1529f67e9caf6cd88a84aaaa64 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungqr000077500000000000000000000057301325016550400166650ustar00rootroot00000000000000--- :name: cungqr :md5sum: 2b4cd874b9af0ac7808c9a204c885182 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungr2000077500000000000000000000044241325016550400165650ustar00rootroot00000000000000--- :name: cungr2 :md5sum: f7132b5708349bba4dac10d58a1884cb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungrq000077500000000000000000000057161325016550400166710ustar00rootroot00000000000000--- :name: cungrq :md5sum: d746240bdc6859afd89dd9dca3203e48 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cungtr000077500000000000000000000054611325016550400166710ustar00rootroot00000000000000--- :name: cungtr :md5sum: 94a00f30110e67f59804739159d1addd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunm2l000077500000000000000000000072561325016550400165730ustar00rootroot00000000000000--- :name: cunm2l :md5sum: c3593596199bc8c9370014ab907efab6 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunm2r000077500000000000000000000072571325016550400166020ustar00rootroot00000000000000--- :name: cunm2r :md5sum: d6529aa837a2fa06b92428b617c42361 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmbr000077500000000000000000000142501325016550400166510ustar00rootroot00000000000000--- :name: cunmbr :md5sum: a13ce3f061a13acebd53efeb52145740 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - MIN(nq,k) - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :extras: nq: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmhr000077500000000000000000000122201325016550400166520ustar00rootroot00000000000000--- :name: cunmhr :md5sum: a0c17c73a1656100d77e0619a76540c4 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - m-1 - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunml2000077500000000000000000000073141325016550400165660ustar00rootroot00000000000000--- :name: cunml2 :md5sum: 978c51e7604473ec5f48cacdc20d9c44 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmlq000077500000000000000000000105311325016550400166600ustar00rootroot00000000000000--- :name: cunmlq :md5sum: dc642a8768f6ae415361d81170fba6a4 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmql000077500000000000000000000104631325016550400166640ustar00rootroot00000000000000--- :name: cunmql :md5sum: e075186612aa4b25773c8e1ad534f676 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmqr000077500000000000000000000104761325016550400166760ustar00rootroot00000000000000--- :name: cunmqr :md5sum: 5596f3f65a6800dec1c8bfdab7678536 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmr2000077500000000000000000000073131325016550400165730ustar00rootroot00000000000000--- :name: cunmr2 :md5sum: 9fa3edd4ed9752efc8febe2650619540 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmr3000077500000000000000000000111601325016550400165670ustar00rootroot00000000000000--- :name: cunmr3 :md5sum: 67cac9132bae1f638b544e1094b357af :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmrq000077500000000000000000000105201325016550400166640ustar00rootroot00000000000000--- :name: cunmrq :md5sum: 063a5e5bb2f967f76f827e9f6cf476bb :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmrz000077500000000000000000000114461325016550400167050ustar00rootroot00000000000000--- :name: cunmrz :md5sum: 78c9a267970adfd685ebe4eeafc6e1ec :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cunmtr000077500000000000000000000116551325016550400167010ustar00rootroot00000000000000--- :name: cunmtr :md5sum: 11d3fb40772ec5f0829d5a084bbba746 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - m-1 - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cupgtr000077500000000000000000000044421325016550400166710ustar00rootroot00000000000000--- :name: cupgtr :md5sum: 987966702842f36fc0ef177987253956 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - tau: :type: complex :intent: input :dims: - ldtau - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/cupmtr000077500000000000000000000071241325016550400166770ustar00rootroot00000000000000--- :name: cupmtr :md5sum: 89521ca27f55bfeeba2a81b50aae3789 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - m*(m+1)/2 - tau: :type: complex :intent: input :dims: - m-1 - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dbbcsd000077500000000000000000000224741325016550400166130ustar00rootroot00000000000000--- :name: dbbcsd :md5sum: 26a801cd779a10106a829b0e401c7a94 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: doublereal :intent: input/output :dims: - q - phi: :type: doublereal :intent: input :dims: - q-1 - u1: :type: doublereal :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: doublereal :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublereal :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: doublereal :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: doublereal :intent: output :dims: - q - b11e: :type: doublereal :intent: output :dims: - q-1 - b12d: :type: doublereal :intent: output :dims: - q - b12e: :type: doublereal :intent: output :dims: - q-1 - b21d: :type: doublereal :intent: output :dims: - q - b21e: :type: doublereal :intent: output :dims: - q-1 - b22d: :type: doublereal :intent: output :dims: - q - b22e: :type: doublereal :intent: output :dims: - q-1 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dbdsdc000077500000000000000000000167221325016550400166140ustar00rootroot00000000000000--- :name: dbdsdc :md5sum: 27fa176c325154bb7249d301f950baf5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - compq: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - u: :type: doublereal :intent: output :dims: - "lsame_(&compq,\"I\") ? ldu : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - "lsame_(&compq,\"I\") ? ldvt : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldvt: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - "lsame_(&compq,\"I\") ? (lsame_(&compq,\"P\") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0" - iq: :type: integer :intent: output :dims: - "lsame_(&compq,\"I\") ? (lsame_(&compq,\"P\") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0" - work: :type: doublereal :intent: workspace :dims: - "MAX(1,lsame_(&compq,\"N\") ? 4*n : lsame_(&compq,\"P\") ? 6*n : lsame_(&compq,\"I\") ? 3*n*n+4*n : 0)" - iwork: :type: integer :intent: workspace :dims: - 8*n - info: :type: integer :intent: output :substitutions: c__0: "0" c__9: "9" ldvt: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" ldu: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" smlsiz: "ilaenv_(&c__9, \"DBDSDC\", \" \", &c__0, &c__0, &c__0, &c__0)" :extras: c__0: integer c__9: integer smlsiz: real :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dbdsqr000077500000000000000000000166441325016550400166530ustar00rootroot00000000000000--- :name: dbdsqr :md5sum: 43c08e3c38f901cfbaf8d922647ff3dd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - vt: :type: doublereal :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ddisna000077500000000000000000000057321325016550400166320ustar00rootroot00000000000000--- :name: ddisna :md5sum: ea986ef961f5fb1f30ce6fd9d42e776f :category: :subroutine :arguments: - job: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - sep: :type: doublereal :intent: output :dims: - "lsame_(&job,\"E\") ? m : ((lsame_(&job,\"L\")) || (lsame_(&job,\"R\"))) ? MIN(m,n) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbbrd000077500000000000000000000115341325016550400166110ustar00rootroot00000000000000--- :name: dgbbrd :md5sum: b1d106c514038584d5188d2ac5af4fbe :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - q: :type: doublereal :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: doublereal :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbcon000077500000000000000000000065361325016550400166270ustar00rootroot00000000000000--- :name: dgbcon :md5sum: 3a7c574975c857211d37ef3e3a3e933d :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbequ000077500000000000000000000075461325016550400166440ustar00rootroot00000000000000--- :name: dgbequ :md5sum: 1fed30e38d10a573adca3196ba837d4b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - MAX(1,m) - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbequb000077500000000000000000000104061325016550400167730ustar00rootroot00000000000000--- :name: dgbequb :md5sum: ae4e33ebda663716b4b660ecd0995df2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbrfs000077500000000000000000000130151325016550400166300ustar00rootroot00000000000000--- :name: dgbrfs :md5sum: b56549a2e7880c6fef2c12fa919a14d7 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbrfsx000077500000000000000000000427051325016550400170300ustar00rootroot00000000000000--- :name: dgbrfsx :md5sum: 1b319e91516e78be13a336d591bba7fe :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbsv000077500000000000000000000115061325016550400164710ustar00rootroot00000000000000--- :name: dgbsv :md5sum: 310da022bace27c3272e6f5cd692a164 :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbsvx000077500000000000000000000344001325016550400166570ustar00rootroot00000000000000--- :name: dgbsvx :md5sum: 0129a67da42e6c8b84a014e106b7f3e1 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: output :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/dgbsvxx000077500000000000000000000564761325016550400170700ustar00rootroot00000000000000--- :name: dgbsvxx :md5sum: ed3b7b61f317423e291101840cbbe4a8 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/dgbtf2000077500000000000000000000074371325016550400165440ustar00rootroot00000000000000--- :name: dgbtf2 :md5sum: 57c00fcbe37b532c6461b03a84b5c002 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbtrf000077500000000000000000000074241325016550400166400ustar00rootroot00000000000000--- :name: dgbtrf :md5sum: 748601a9d6892d3d72a222a317ff462a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgbtrs000077500000000000000000000060261325016550400166520ustar00rootroot00000000000000--- :name: dgbtrs :md5sum: a4125cfc65d3f9c498b42c6cbaaedb91 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgebak000077500000000000000000000054771325016550400166130ustar00rootroot00000000000000--- :name: dgebak :md5sum: 1422ed99bdfebc076a90d3f7631e2619 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgebal000077500000000000000000000104341325016550400166010ustar00rootroot00000000000000--- :name: dgebal :md5sum: 45f9fb3e24750e422000cd2ba1545396 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgebd2000077500000000000000000000133161325016550400165140ustar00rootroot00000000000000--- :name: dgebd2 :md5sum: d6a391ab865d33b54860820be4bb9eff :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublereal :intent: output :dims: - MIN(m,n) - taup: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgebrd000077500000000000000000000146141325016550400166160ustar00rootroot00000000000000--- :name: dgebrd :md5sum: 406bda8120eb4cf0266486d3331f12ce :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublereal :intent: output :dims: - MIN(m,n) - taup: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgecon000077500000000000000000000050351325016550400166230ustar00rootroot00000000000000--- :name: dgecon :md5sum: ce08c3cbca5bd107bc2e0dac5059f801 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeequ000077500000000000000000000065741325016550400166470ustar00rootroot00000000000000--- :name: dgeequ :md5sum: 24654d259d19a245582b147d74ff0ecb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeequb000077500000000000000000000074241325016550400170040ustar00rootroot00000000000000--- :name: dgeequb :md5sum: c63a97ad851901733ab2b896a9ad93a8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgees000077500000000000000000000160071325016550400164540ustar00rootroot00000000000000--- :name: dgees :md5sum: 6e68756fb1b8fae3f71e2cb0f98b4115 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublereal - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vs: :type: doublereal :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeesx000077500000000000000000000237671325016550400166570ustar00rootroot00000000000000--- :name: dgeesx :md5sum: 86306dfb6f982e18929b60f86f2c7b1f :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublereal - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vs: :type: doublereal :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: doublereal :intent: output - rcondv: :type: doublereal :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeev000077500000000000000000000132261325016550400164570ustar00rootroot00000000000000--- :name: dgeev :md5sum: aabe3b38aa4ecc1eaef182e801f27ca4 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 4*n : 3*n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeevx000077500000000000000000000252641325016550400166540ustar00rootroot00000000000000--- :name: dgeevx :md5sum: 609542a2421694e34131836059fd6901 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 0 : 2*n-2" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgegs000077500000000000000000000164761325016550400164700ustar00rootroot00000000000000--- :name: dgegs :md5sum: c49c4cd3c8469332e43b4d911700e384 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vsl: :type: doublereal :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublereal :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 4*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgegv000077500000000000000000000257251325016550400164700ustar00rootroot00000000000000--- :name: dgegv :md5sum: 155f15d8861adb20fd687c0f414a941d :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgehd2000077500000000000000000000074241325016550400165250ustar00rootroot00000000000000--- :name: dgehd2 :md5sum: 4829ae3085abb612140e17e11185438d :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgehrd000077500000000000000000000113511325016550400166170ustar00rootroot00000000000000--- :name: dgehrd :md5sum: 9dba8e3f6472cee11825e94623b48f41 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgejsv000077500000000000000000002203111325016550400166420ustar00rootroot00000000000000--- :name: dgejsv :md5sum: 48e427f846d8774d81a35aecade0f887 :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobr: :type: char :intent: input - jobt: :type: char :intent: input - jobp: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: doublereal :intent: output :dims: - n - u: :type: doublereal :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - v: :type: doublereal :intent: output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: doublereal :intent: input/output :dims: - lwork - 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 :dims: - m+3*n - info: :type: integer :intent: output :substitutions: ldu: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? m : 1" ldv: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? n : 1" :fortran_help: " 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@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" ruby-lapack-1.8.1/dev/defs/dgelq2000077500000000000000000000050031325016550400165350ustar00rootroot00000000000000--- :name: dgelq2 :md5sum: efc77ee160fccc12e8137440aba81433 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgelqf000077500000000000000000000072531325016550400166320ustar00rootroot00000000000000--- :name: dgelqf :md5sum: b4d5555b345b2643eab5d4e5c10862ee :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgels000077500000000000000000000132741325016550400164660ustar00rootroot00000000000000--- :name: dgels :md5sum: 9260fd1d04cb3579ce975a620c16558c :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/dgelsd000077500000000000000000000160511325016550400166260ustar00rootroot00000000000000--- :name: dgelsd :md5sum: 491fcb0747c66a3474c70cafe89194ae :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - info: :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)) nlvl: MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1)) smlsiz: ilaenv_(&c__9,"DGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " 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 transformations 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" ruby-lapack-1.8.1/dev/defs/dgelss000077500000000000000000000115661325016550400166530ustar00rootroot00000000000000--- :name: dgelss :md5sum: ba7d9a1ddb43c981531b0f82a0a65fd4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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: 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\ *\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" ruby-lapack-1.8.1/dev/defs/dgelsx000077500000000000000000000120561325016550400166530ustar00rootroot00000000000000--- :name: dgelsx :md5sum: 8510818f8072eca24262ab83fcc2c9b9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgelsy000077500000000000000000000144771325016550400166650ustar00rootroot00000000000000--- :name: dgelsy :md5sum: e2df8916f4fbca7d7953269868109558 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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: 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\ *\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" ruby-lapack-1.8.1/dev/defs/dgeql2000077500000000000000000000051661325016550400165470ustar00rootroot00000000000000--- :name: dgeql2 :md5sum: a28ed88137c6b697773895e45d0d13a1 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqlf000077500000000000000000000075041325016550400166310ustar00rootroot00000000000000--- :name: dgeqlf :md5sum: fa29ffe456888362b95f7fa8db470284 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqp3000077500000000000000000000074251325016550400165540ustar00rootroot00000000000000--- :name: dgeqp3 :md5sum: bbaf1198c839c6a81f6e98424eecce52 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n+1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqpf000077500000000000000000000064561325016550400166420ustar00rootroot00000000000000--- :name: dgeqpf :md5sum: 357c7be8c28d16facf6f9fa20d73b074 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqr2000077500000000000000000000047741325016550400165610ustar00rootroot00000000000000--- :name: dgeqr2 :md5sum: fb9ab1f2a4dd3ec44720edcbe890256c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqr2p000077500000000000000000000047761325016550400167430ustar00rootroot00000000000000--- :name: dgeqr2p :md5sum: 59f93cf670a8bce6baf99ccbb702ece5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqrf000077500000000000000000000073031325016550400166340ustar00rootroot00000000000000--- :name: dgeqrf :md5sum: eff1033d66c3942bfe1fce5ed78f7b1d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgeqrfp000077500000000000000000000073071325016550400170200ustar00rootroot00000000000000--- :name: dgeqrfp :md5sum: 639abd04a0431d1e20e6a81968c6f63e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgerfs000077500000000000000000000113201325016550400166300ustar00rootroot00000000000000--- :name: dgerfs :md5sum: 446e892116e20158a8eebd9ecff5461f :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgerfsx000077500000000000000000000403241325016550400170260ustar00rootroot00000000000000--- :name: dgerfsx :md5sum: ebbb73fcc0262d3a5b61f65f235f8830 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgerq2000077500000000000000000000051731325016550400165530ustar00rootroot00000000000000--- :name: dgerq2 :md5sum: ec6dcb765aef641986c3c35e04eff023 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgerqf000077500000000000000000000075141325016550400166400ustar00rootroot00000000000000--- :name: dgerqf :md5sum: 522daeb5235e5276cf26a8dc9440df57 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgesc2000077500000000000000000000045511325016550400165350ustar00rootroot00000000000000--- :name: dgesc2 :md5sum: 2545d85fa9c437128db2590785846062 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: doublereal :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgesdd000077500000000000000000000171371325016550400166240ustar00rootroot00000000000000--- :name: dgesdd :md5sum: 31309f179f21f12ed15aae51ac120086 :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublereal :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 8*MIN(m,n) - info: :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\") || 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\ *\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" ruby-lapack-1.8.1/dev/defs/dgesv000077500000000000000000000061041325016550400164720ustar00rootroot00000000000000--- :name: dgesv :md5sum: 8ab66d02ed18d053ba3faf7a6a1d1ad2 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgesvd000077500000000000000000000160601325016550400166400ustar00rootroot00000000000000--- :name: dgesvd :md5sum: 979b942ecd658c595d1c5fd2d32bac36 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublereal :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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\ * 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" ruby-lapack-1.8.1/dev/defs/dgesvj000077500000000000000000000370121325016550400166460ustar00rootroot00000000000000--- :name: dgesvj :md5sum: df9133f8cb1fdc3793fc40b5c576608e :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: doublereal :intent: output :dims: - n - mv: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: doublereal :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(6,m+n) - info: :type: integer :intent: output :substitutions: lwork: MAX(4,m+n) :fortran_help: " 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@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" ruby-lapack-1.8.1/dev/defs/dgesvx000077500000000000000000000325771325016550400166770ustar00rootroot00000000000000--- :name: dgesvx :md5sum: cb38332edb915fb28cae04bc3431f6ab :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: output :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/dgesvxx000077500000000000000000000550621325016550400170610ustar00rootroot00000000000000--- :name: dgesvxx :md5sum: 66e137ddd86d76cfb4ae5f95a9fce4a7 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/dgetc2000077500000000000000000000050271325016550400165350ustar00rootroot00000000000000--- :name: dgetc2 :md5sum: 8407e50951ea8e41f50aa9499510d542 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgetf2000077500000000000000000000045411325016550400165400ustar00rootroot00000000000000--- :name: dgetf2 :md5sum: 4a9f270f6962bef69979fdff93c30a0c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgetrf000077500000000000000000000045471325016550400166460ustar00rootroot00000000000000--- :name: dgetrf :md5sum: a4dcbe6d74786df056780307768b0b99 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgetri000077500000000000000000000052401325016550400166400ustar00rootroot00000000000000--- :name: dgetri :md5sum: c484cb60864677da7365b61f53b577c7 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgetrs000077500000000000000000000047441325016550400166620ustar00rootroot00000000000000--- :name: dgetrs :md5sum: 065854a0ebb4465961ce7034ae87b2eb :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggbak000077500000000000000000000074371325016550400166130ustar00rootroot00000000000000--- :name: dggbak :md5sum: b7d43e8ff3f48a5a2749288abaa6a7c0 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: doublereal :intent: input :dims: - n - rscale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggbal000077500000000000000000000120331325016550400166000ustar00rootroot00000000000000--- :name: dggbal :md5sum: 24ff4f10c5e8790d8d13027b9337a32b :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgges000077500000000000000000000233771325016550400164660ustar00rootroot00000000000000--- :name: dgges :md5sum: 3eca96ecb9c176b7624b865b6032c1e7 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: doublereal - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vsl: :type: doublereal :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublereal :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(8*n,6*n+16) - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggesx000077500000000000000000000321351325016550400166460ustar00rootroot00000000000000--- :name: dggesx :md5sum: f3a7ebdeb62d6f9d7568125a545c4ee7 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: doublereal - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vsl: :type: doublereal :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublereal :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: doublereal :intent: output :dims: - "2" - rcondv: :type: doublereal :intent: output :dims: - "2" - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggev000077500000000000000000000163651325016550400164700ustar00rootroot00000000000000--- :name: dggev :md5sum: 27e8c7132a2cb715913cbcefadd0f718 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,8*n) - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggevx000077500000000000000000000344101325016550400166470ustar00rootroot00000000000000--- :name: dggevx :md5sum: d820d02e84e8720e11cd584403d567e3 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - bbnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - "lsame_(&sense,\"E\") ? 0 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggglm000077500000000000000000000123661325016550400166320ustar00rootroot00000000000000--- :name: dggglm :md5sum: b132b24d18eb3c974ddf79f3c310f812 :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - x: :type: doublereal :intent: output :dims: - m - y: :type: doublereal :intent: output :dims: - p - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgghrd000077500000000000000000000136131325016550400166240ustar00rootroot00000000000000--- :name: dgghrd :md5sum: d3387383d791c77ea93cb356899973a1 :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgglse000077500000000000000000000122201325016550400166230ustar00rootroot00000000000000--- :name: dgglse :md5sum: f8e4bc124d9d19025708402676a2883b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - m - d: :type: doublereal :intent: input/output :dims: - p - x: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggqrf000077500000000000000000000156421325016550400166430ustar00rootroot00000000000000--- :name: dggqrf :md5sum: efab5563e7dc3ab5cf95b5adc2c09cfe :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: doublereal :intent: output :dims: - MIN(n,m) - b: :type: doublereal :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: doublereal :intent: output :dims: - MIN(n,p) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggrqf000077500000000000000000000156031325016550400166400ustar00rootroot00000000000000--- :name: dggrqf :md5sum: 17620fbd0172e2c1610c61d9628e64cf :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: doublereal :intent: output :dims: - MIN(m,n) - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: doublereal :intent: output :dims: - MIN(p,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dggsvd000077500000000000000000000244341325016550400166460ustar00rootroot00000000000000--- :name: dggsvd :md5sum: 478a765175c3dec9fe66f8749e4eba83 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublereal :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublereal :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(3*n,m - p)+n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: 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" :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\ * 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" ruby-lapack-1.8.1/dev/defs/dggsvp000077500000000000000000000153671325016550400166670ustar00rootroot00000000000000--- :name: dggsvp :md5sum: ce4882820e369faca6fa14e28c83ea25 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: doublereal :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublereal :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - tau: :type: doublereal :intent: workspace :dims: - n - work: :type: doublereal :intent: workspace :dims: - MAX(MAX(3*n,m),p) - info: :type: integer :intent: output :substitutions: 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" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgsvj0000077500000000000000000000170451325016550400165650ustar00rootroot00000000000000--- :name: dgsvj0 :md5sum: f57558f8638ae633075b0b7979c9eeed :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - sva: :type: doublereal :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: doublereal :intent: input - sfmin: :type: doublereal :intent: input - tol: :type: doublereal :intent: input - nsweep: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " 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@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" ruby-lapack-1.8.1/dev/defs/dgsvj1000077500000000000000000000211071325016550400165600ustar00rootroot00000000000000--- :name: dgsvj1 :md5sum: 5a0a9a6d9b6517aee627cb9db7764663 :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - sva: :type: doublereal :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: doublereal :intent: input - sfmin: :type: doublereal :intent: input - tol: :type: doublereal :intent: input - nsweep: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgtcon000077500000000000000000000067421325016550400166500ustar00rootroot00000000000000--- :name: dgtcon :md5sum: 33c789ced03959494b2d8ea9a37671e7 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgtrfs000077500000000000000000000131511325016550400166530ustar00rootroot00000000000000--- :name: dgtrfs :md5sum: 14bdb4c078a4d0b6cccf1b5a3d92eeaa :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - dlf: :type: doublereal :intent: input :dims: - n-1 - df: :type: doublereal :intent: input :dims: - n - duf: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgtsv000077500000000000000000000057311325016550400165160ustar00rootroot00000000000000--- :name: dgtsv :md5sum: 049008f7af4d85ec1a04d1743b655d80 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input/output :dims: - n-1 - d: :type: doublereal :intent: input/output :dims: - n - du: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgtsvx000077500000000000000000000235611325016550400167070ustar00rootroot00000000000000--- :name: dgtsvx :md5sum: 65257f06318d08af23974f8758a267a7 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - dlf: :type: doublereal :intent: input/output :dims: - n-1 - df: :type: doublereal :intent: input/output :dims: - n - duf: :type: doublereal :intent: input/output :dims: - n-1 - du2: :type: doublereal :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgttrf000077500000000000000000000061501325016550400166550ustar00rootroot00000000000000--- :name: dgttrf :md5sum: 306eba329147375407f9d5681c1499cc :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: doublereal :intent: input/output :dims: - n-1 - d: :type: doublereal :intent: input/output :dims: - n - du: :type: doublereal :intent: input/output :dims: - n-1 - du2: :type: doublereal :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgttrs000077500000000000000000000070401325016550400166710ustar00rootroot00000000000000--- :name: dgttrs :md5sum: b93484e4a60657d1a7d75fd2575b68f7 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dgtts2000077500000000000000000000060321325016550400165710ustar00rootroot00000000000000--- :name: dgtts2 :md5sum: 709bd757314a13f631c15ff3b78523f5 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dhgeqz000077500000000000000000000253121325016550400166460ustar00rootroot00000000000000--- :name: dhgeqz :md5sum: bce30abcdf7b59c766869e0ee9849a6a :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dhsein000077500000000000000000000214141325016550400166350ustar00rootroot00000000000000--- :name: dhsein :md5sum: f1f28c22000db86e9f2f6f69e7dba216 :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - h: :type: doublereal :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: input/output :dims: - n - wi: :type: doublereal :intent: input :dims: - n - vl: :type: doublereal :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - (n+2)*n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dhseqr000077500000000000000000000301011325016550400166420ustar00rootroot00000000000000--- :name: dhseqr :md5sum: b1117e715390f2b96127cf6b714d4ccf :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/disnan000077500000000000000000000013551325016550400166410ustar00rootroot00000000000000--- :name: disnan :md5sum: 6226d5dde19479c96fbf22f35fdf0c6c :category: :function :type: logical :arguments: - din: :type: doublereal :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_gbamv000077500000000000000000000121271325016550400173000ustar00rootroot00000000000000--- :name: dla_gbamv :md5sum: 49d5577966474bf7d02e9b741c6d963a :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: doublereal :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - ldab: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/dla_gbrcond000077500000000000000000000112371325016550400176230ustar00rootroot00000000000000--- :name: dla_gbrcond :md5sum: 166b58ae6ab01504cac311045c0152cb :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 5*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_gbrfsx_extended000077500000000000000000000364001325016550400213570ustar00rootroot00000000000000--- :name: dla_gbrfsx_extended :md5sum: 77409c41c105cbcc5653d6d05aeb4421 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: 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\ * 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" ruby-lapack-1.8.1/dev/defs/dla_gbrpvgrw000077500000000000000000000054631325016550400200510ustar00rootroot00000000000000--- :name: dla_gbrpvgrw :md5sum: 8b95eb4dff88659ee9254d8e892a9501 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_geamv000077500000000000000000000114121325016550400172770ustar00rootroot00000000000000--- :name: dla_geamv :md5sum: ab3758acf8bfa5ffbbcdc48d5024599a :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)" - incy: :type: integer :intent: input :substitutions: lda: MAX(1, m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_gercond000077500000000000000000000076401325016550400176310ustar00rootroot00000000000000--- :name: dla_gercond :md5sum: 2049376510eb05d8caae1262a8c242ec :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_gerfsx_extended000077500000000000000000000355611325016550400213710ustar00rootroot00000000000000--- :name: dla_gerfsx_extended :md5sum: 3d7ad12043072b489bb0902dafc971c6 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - errs_n: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - errs_c: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n_norms: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_lin_berr000077500000000000000000000047321325016550400200030ustar00rootroot00000000000000--- :name: dla_lin_berr :md5sum: 3661649ee822d0355f02d5b222d14624 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: doublereal :intent: input :dims: - n - nrhs - ayb: :type: doublereal :intent: input :dims: - n - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_porcond000077500000000000000000000071061325016550400176510ustar00rootroot00000000000000--- :name: dla_porcond :md5sum: ad89241edd2e8e4f14c40b59471af634 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_porfsx_extended000077500000000000000000000346611325016550400214140ustar00rootroot00000000000000--- :name: dla_porfsx_extended :md5sum: ee3648f5d40164c388f6fca867c879bb :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_porpvgrw000077500000000000000000000046341325016550400200760ustar00rootroot00000000000000--- :name: dla_porpvgrw :md5sum: 808a3e0cfa3cafe090522d7d169ee362 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: doublereal :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_rpvgrw000077500000000000000000000040621325016550400175320ustar00rootroot00000000000000--- :name: dla_rpvgrw :md5sum: f34d9e53195025ba4075345e34febe49 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_syamv000077500000000000000000000112031325016550400173350ustar00rootroot00000000000000--- :name: dla_syamv :md5sum: ead79408a2a6f903222a56b448313185 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_syrcond000077500000000000000000000076161325016550400176740ustar00rootroot00000000000000--- :name: dla_syrcond :md5sum: 8136e050755bb66761ca2f199b0b2e84 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_syrfsx_extended000077500000000000000000000352431325016550400214260ustar00rootroot00000000000000--- :name: dla_syrfsx_extended :md5sum: 5b2a7698bbce8c0dc9f743b47f9a53f0 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_syrpvgrw000077500000000000000000000057451325016550400201170ustar00rootroot00000000000000--- :name: dla_syrpvgrw :md5sum: 801aa0fa7e5fb338b1f7a6dbea3e4b55 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dla_wwaddw000077500000000000000000000026521325016550400175030ustar00rootroot00000000000000--- :name: dla_wwaddw :md5sum: da58c78a12f4aa29fcb0e297c45ff392 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - n - y: :type: doublereal :intent: input/output :dims: - n - w: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlabad000077500000000000000000000031711325016550400165720ustar00rootroot00000000000000--- :name: dlabad :md5sum: 22dcceea234b4e85f0bf77e6bb51ee52 :category: :subroutine :arguments: - small: :type: doublereal :intent: input/output - large: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlabrd000077500000000000000000000146751325016550400166260ustar00rootroot00000000000000--- :name: dlabrd :md5sum: cb76485d4ef4288d000a950edfd4b95f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MAX(1,nb) - e: :type: doublereal :intent: output :dims: - MAX(1,nb) - tauq: :type: doublereal :intent: output :dims: - MAX(1,nb) - taup: :type: doublereal :intent: output :dims: - MAX(1,nb) - x: :type: doublereal :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: doublereal :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: m ldy: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlacn2000077500000000000000000000057141325016550400165330ustar00rootroot00000000000000--- :name: dlacn2 :md5sum: cc8a61551ef83735cc8fbda43e5751a3 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublereal :intent: workspace :dims: - n - x: :type: doublereal :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlacon000077500000000000000000000047501325016550400166270ustar00rootroot00000000000000--- :name: dlacon :md5sum: 7ed7cddcc0aa7b3a8a541f6acef383f1 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublereal :intent: workspace :dims: - n - x: :type: doublereal :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlacpy000077500000000000000000000042621325016550400166410ustar00rootroot00000000000000--- :name: dlacpy :md5sum: 10366fbf2a10d962bba69e321b7c3c7b :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dladiv000077500000000000000000000027521325016550400166320ustar00rootroot00000000000000--- :name: dladiv :md5sum: 41da7dda9474acb9983598430ee07a80 :category: :subroutine :arguments: - a: :type: doublereal :intent: input - b: :type: doublereal :intent: input - c: :type: doublereal :intent: input - d: :type: doublereal :intent: input - p: :type: doublereal :intent: output - q: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlae2000077500000000000000000000036301325016550400163520ustar00rootroot00000000000000--- :name: dlae2 :md5sum: 6634a79d68e158282cf44e0eded12a8d :category: :subroutine :arguments: - a: :type: doublereal :intent: input - b: :type: doublereal :intent: input - c: :type: doublereal :intent: input - rt1: :type: doublereal :intent: output - rt2: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaebz000077500000000000000000000300361325016550400166240ustar00rootroot00000000000000--- :name: dlaebz :md5sum: 667b9d1d21f6f805330766d1f74f173b :category: :subroutine :arguments: - ijob: :type: integer :intent: input - nitmax: :type: integer :intent: input - n: :type: integer :intent: input - mmax: :type: integer :intent: input - minp: :type: integer :intent: input - nbmin: :type: integer :intent: input - abstol: :type: doublereal :intent: input - reltol: :type: doublereal :intent: input - pivmin: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n - e2: :type: doublereal :intent: input :dims: - n - nval: :type: integer :intent: input/output :dims: - "(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0" - ab: :type: doublereal :intent: input/output :dims: - mmax - "2" - c: :type: doublereal :intent: input/output :dims: - "ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0" - mout: :type: integer :intent: output - nab: :type: integer :intent: input/output :dims: - mmax - "2" - work: :type: doublereal :intent: workspace :dims: - mmax - iwork: :type: integer :intent: workspace :dims: - mmax - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed0000077500000000000000000000123561325016550400165210ustar00rootroot00000000000000--- :name: dlaed0 :md5sum: 337ae89b96bbbde72236a7ce62eb8536 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: doublereal :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0" - iwork: :type: integer :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0" - info: :type: integer :intent: output :substitutions: ldqs: "icompq == 1 ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed1000077500000000000000000000120121325016550400165070ustar00rootroot00000000000000--- :name: dlaed1 :md5sum: de28a4b248244bebc9ea6c8ab7809f3b :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: doublereal :intent: input - cutpnt: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n + pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/dlaed2000077500000000000000000000146531325016550400165250ustar00rootroot00000000000000--- :name: dlaed2 :md5sum: d8f308f281405229efe4f87a4a67b923 :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: doublereal :intent: input/output - z: :type: doublereal :intent: input :dims: - n - dlamda: :type: doublereal :intent: output :dims: - n - w: :type: doublereal :intent: output :dims: - n - q2: :type: doublereal :intent: output :dims: - pow(n1,2)+pow(n-n1,2) - indx: :type: integer :intent: workspace :dims: - n - indxc: :type: integer :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed3000077500000000000000000000126561325016550400165270ustar00rootroot00000000000000--- :name: dlaed3 :md5sum: 43bf65fad7f2277e7f8939b3c02e35ac :category: :subroutine :arguments: - k: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: doublereal :intent: input - dlamda: :type: doublereal :intent: input/output :dims: - k - q2: :type: doublereal :intent: input :dims: - n - n - indx: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - w: :type: doublereal :intent: input/output :dims: - k - s: :type: doublereal :intent: workspace :dims: - MAX(1,k) - (n1 + 1) - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed4000077500000000000000000000065531325016550400165270ustar00rootroot00000000000000--- :name: dlaed4 :md5sum: 2bf936115b6fbea109694f74fb7b08e3 :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - z: :type: doublereal :intent: input :dims: - n - delta: :type: doublereal :intent: output :dims: - n - rho: :type: doublereal :intent: input - dlam: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed5000077500000000000000000000041041325016550400165160ustar00rootroot00000000000000--- :name: dlaed5 :md5sum: 97c4dbce5d8f0302e9cdfe76525ae209 :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - "2" - z: :type: doublereal :intent: input :dims: - "2" - delta: :type: doublereal :intent: output :dims: - "2" - rho: :type: doublereal :intent: input - dlam: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed6000077500000000000000000000061231325016550400165220ustar00rootroot00000000000000--- :name: dlaed6 :md5sum: e039fc917dcc0ea6e9bd27545f59234c :category: :subroutine :arguments: - kniter: :type: integer :intent: input - orgati: :type: logical :intent: input - rho: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - "3" - z: :type: doublereal :intent: input :dims: - "3" - finit: :type: doublereal :intent: input - tau: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed7000077500000000000000000000177731325016550400165400ustar00rootroot00000000000000--- :name: dlaed7 :md5sum: 28c523ba917e198d63509b14a5f28ee1 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: output :dims: - n - rho: :type: doublereal :intent: input - cutpnt: :type: integer :intent: input - qstore: :type: doublereal :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: doublereal :intent: input :dims: - "2" - n*LG(n) - work: :type: doublereal :intent: workspace :dims: - 3*n+qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/dlaed8000077500000000000000000000164371325016550400165350ustar00rootroot00000000000000--- :name: dlaed8 :md5sum: d8ce12a706721da54812694fab3a1bbe :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - "icompq==0 ? 0 : ldq" - "icompq==0 ? 0 : n" - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input :dims: - n - rho: :type: doublereal :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - n - dlamda: :type: doublereal :intent: output :dims: - n - q2: :type: doublereal :intent: output :dims: - "icompq==0 ? 0 : ldq2" - "icompq==0 ? 0 : n" - ldq2: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: doublereal :intent: output :dims: - "2" - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldq2: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaed9000077500000000000000000000102351325016550400165240ustar00rootroot00000000000000--- :name: dlaed9 :md5sum: e45625c97ed5b50036009a7a23bf1afd :category: :subroutine :arguments: - k: :type: integer :intent: input - kstart: :type: integer :intent: input - kstop: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MAX(1,n) - q: :type: doublereal :intent: workspace :dims: - ldq - MAX(1,n) - ldq: :type: integer :intent: input - rho: :type: doublereal :intent: input - dlamda: :type: doublereal :intent: input :dims: - k - w: :type: doublereal :intent: input :dims: - k - s: :type: doublereal :intent: output :dims: - lds - k - lds: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldq: MAX( 1, n ) lds: MAX( 1, k ) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaeda000077500000000000000000000105151325016550400165750ustar00rootroot00000000000000--- :name: dlaeda :md5sum: 3830f904cb7ee44d5b077cc4cdc94789 :category: :subroutine :arguments: - n: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: doublereal :intent: input :dims: - "2" - n*LG(n) - q: :type: doublereal :intent: input :dims: - pow(n,2) - qptr: :type: integer :intent: input :dims: - ldqptr - z: :type: doublereal :intent: output :dims: - n - ztemp: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldqptr-2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaein000077500000000000000000000104671325016550400166250ustar00rootroot00000000000000--- :name: dlaein :md5sum: 8991c91a48bac18d81e2639cd6de073f :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: doublereal :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: input - wi: :type: doublereal :intent: input - vr: :type: doublereal :intent: input/output :dims: - n - vi: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - eps3: :type: doublereal :intent: input - smlnum: :type: doublereal :intent: input - bignum: :type: doublereal :intent: input - info: :type: integer :intent: output :substitutions: ldb: n+1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaev2000077500000000000000000000050131325016550400165350ustar00rootroot00000000000000--- :name: dlaev2 :md5sum: cb9b88b5e51e149c658216cec1ab2953 :category: :subroutine :arguments: - a: :type: doublereal :intent: input - b: :type: doublereal :intent: input - c: :type: doublereal :intent: input - rt1: :type: doublereal :intent: output - rt2: :type: doublereal :intent: output - cs1: :type: doublereal :intent: output - sn1: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaexc000077500000000000000000000061011325016550400166170ustar00rootroot00000000000000--- :name: dlaexc :md5sum: 56c861d18592b42e26327b9686122ba6 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlag2000077500000000000000000000112221325016550400163500ustar00rootroot00000000000000--- :name: dlag2 :md5sum: cb3cffe0121d3cdef959429272b11c8d :category: :subroutine :arguments: - a: :type: doublereal :intent: input :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - safmin: :type: doublereal :intent: input - scale1: :type: doublereal :intent: output - scale2: :type: doublereal :intent: output - wr1: :type: doublereal :intent: output - wr2: :type: doublereal :intent: output - wi: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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 threshold 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\ * threshold 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" ruby-lapack-1.8.1/dev/defs/dlag2s000077500000000000000000000044411325016550400165400ustar00rootroot00000000000000--- :name: dlag2s :md5sum: 669e5e37ddea7cbcff65fc0b9ae1eca2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: real :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,m) :fortran_help: " 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 conversion 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" ruby-lapack-1.8.1/dev/defs/dlags2000077500000000000000000000057261325016550400165470ustar00rootroot00000000000000--- :name: dlags2 :md5sum: 2770fd9e10b95116026d93397ade969b :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: doublereal :intent: input - a2: :type: doublereal :intent: input - a3: :type: doublereal :intent: input - b1: :type: doublereal :intent: input - b2: :type: doublereal :intent: input - b3: :type: doublereal :intent: input - csu: :type: doublereal :intent: output - snu: :type: doublereal :intent: output - csv: :type: doublereal :intent: output - snv: :type: doublereal :intent: output - csq: :type: doublereal :intent: output - snq: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlagtf000077500000000000000000000107401325016550400166240ustar00rootroot00000000000000--- :name: dlagtf :md5sum: 3a0ef4d4c7ee1d1045339e13d37e6877 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n - lambda: :type: doublereal :intent: input - b: :type: doublereal :intent: input/output :dims: - n-1 - c: :type: doublereal :intent: input/output :dims: - n-1 - tol: :type: doublereal :intent: input - d: :type: doublereal :intent: output :dims: - n-2 - in: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlagtm000077500000000000000000000061701325016550400166350ustar00rootroot00000000000000--- :name: dlagtm :md5sum: cc3d3f3d4b1b3e13c85f7cbd11769a05 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: doublereal :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: doublereal :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlagts000077500000000000000000000114551325016550400166450ustar00rootroot00000000000000--- :name: dlagts :md5sum: 1e4c232f7c97f49ee5dc23580a208740 :category: :subroutine :arguments: - job: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - n-1 - c: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n-2 - in: :type: integer :intent: input :dims: - n - y: :type: doublereal :intent: input/output :dims: - n - tol: :type: doublereal :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlagv2000077500000000000000000000073171325016550400165500ustar00rootroot00000000000000--- :name: dlagv2 :md5sum: 0213b40436ec590dd32628d8b5e77774 :category: :subroutine :arguments: - a: :type: doublereal :intent: input/output :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - "2" - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - "2" - alphai: :type: doublereal :intent: output :dims: - "2" - beta: :type: doublereal :intent: output :dims: - "2" - csl: :type: doublereal :intent: output - snl: :type: doublereal :intent: output - csr: :type: doublereal :intent: output - snr: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlahqr000077500000000000000000000146331325016550400166430ustar00rootroot00000000000000--- :name: dlahqr :md5sum: a93986d5c9d574d1cd8150a2f4428399 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlahr2000077500000000000000000000116301325016550400165360ustar00rootroot00000000000000--- :name: dlahr2 :md5sum: ae8b6735a5e45955e75ccfa5fab032b6 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MAX(1,nb) - t: :type: doublereal :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublereal :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlahrd000077500000000000000000000106031325016550400166170ustar00rootroot00000000000000--- :name: dlahrd :md5sum: 3992e32cc63ed67be6e1a947a6fe2335 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MAX(1,nb) - t: :type: doublereal :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublereal :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaic1000077500000000000000000000053341325016550400165230ustar00rootroot00000000000000--- :name: dlaic1 :md5sum: c5939e302aa2582a21e74047f303bb4a :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - j - sest: :type: doublereal :intent: input - w: :type: doublereal :intent: input :dims: - j - gamma: :type: doublereal :intent: input - sestpr: :type: doublereal :intent: output - s: :type: doublereal :intent: output - c: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaln2000077500000000000000000000145231325016550400165420ustar00rootroot00000000000000--- :name: dlaln2 :md5sum: 029cdd6fe89ae0077f078ad1c1d1da86 :category: :subroutine :arguments: - ltrans: :type: logical :intent: input - na: :type: integer :intent: input - nw: :type: integer :intent: input - smin: :type: doublereal :intent: input - ca: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - na - lda: :type: integer :intent: input - d1: :type: doublereal :intent: input - d2: :type: doublereal :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nw - ldb: :type: integer :intent: input - wr: :type: doublereal :intent: input - wi: :type: doublereal :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nw - ldx: :type: integer :intent: input - scale: :type: doublereal :intent: output - xnorm: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: ldx: na :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlals0000077500000000000000000000170561325016550400165510ustar00rootroot00000000000000--- :name: dlals0 :md5sum: 1da4beec06cb8156b553b2d754a11426 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublereal :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: doublereal :intent: input :dims: - ldgnum - "2" - difl: :type: doublereal :intent: input :dims: - k - difr: :type: doublereal :intent: input :dims: - ldgnum - "2" - z: :type: doublereal :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: doublereal :intent: input - s: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - k - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlalsa000077500000000000000000000177461325016550400166400ustar00rootroot00000000000000--- :name: dlalsa :md5sum: 96a29d1579174e468115a64a75f6f345 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublereal :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: doublereal :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: doublereal :intent: input :dims: - ldu - nlvl - difr: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - z: :type: doublereal :intent: input :dims: - ldu - nlvl - poles: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - c: :type: doublereal :intent: input :dims: - n - s: :type: doublereal :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlalsd000077500000000000000000000123351325016550400166300ustar00rootroot00000000000000--- :name: dlalsd :md5sum: daa27e524befeb510c616ce5488bea0f :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1) :extras: nlvl: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlamrg000077500000000000000000000037521325016550400166360ustar00rootroot00000000000000--- :name: dlamrg :md5sum: 482180fad6debeccfe564bd4a552d6d5 :category: :subroutine :arguments: - n1: :type: integer :intent: input - n2: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n1+n2 - dtrd1: :type: integer :intent: input - dtrd2: :type: integer :intent: input - index: :type: integer :intent: output :dims: - n1+n2 :substitutions: {} :fortran_help: " 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 arguments 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" ruby-lapack-1.8.1/dev/defs/dlaneg000077500000000000000000000054041325016550400166160ustar00rootroot00000000000000--- :name: dlaneg :md5sum: c5a7742f33a7d96a4fed5f670646bf40 :category: :function :type: integer :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - lld: :type: doublereal :intent: input :dims: - n-1 - sigma: :type: doublereal :intent: input - pivmin: :type: doublereal :intent: input - r: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlangb000077500000000000000000000055551325016550400166220ustar00rootroot00000000000000--- :name: dlangb :md5sum: 5a9301c71e52681db32faa73a8ccc40f :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlange000077500000000000000000000047501325016550400166210ustar00rootroot00000000000000--- :name: dlange :md5sum: 2fe726b4e4a40bde5dcd4f595a41679e :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlangt000077500000000000000000000043201325016550400166310ustar00rootroot00000000000000--- :name: dlangt :md5sum: a56e7eb61491985defd273c24dd9d896 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlanhs000077500000000000000000000045721325016550400166420ustar00rootroot00000000000000--- :name: dlanhs :md5sum: 00f8dcb211edf59271e15369f14cb83b :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlansb000077500000000000000000000063101325016550400166240ustar00rootroot00000000000000--- :name: dlansb :md5sum: 7d865bf099b44083eb35658d545bd4cf :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlansf000077500000000000000000000146211325016550400166340ustar00rootroot00000000000000--- :name: dlansf :md5sum: acc95b8236c6becc6541bc4ec77e258b :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlansp000077500000000000000000000055201325016550400166440ustar00rootroot00000000000000--- :name: dlansp :md5sum: eff9ff5dad54ccade39fa653933603f3 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlanst000077500000000000000000000040411325016550400166450ustar00rootroot00000000000000--- :name: dlanst :md5sum: 615e091890476d886b6641697bfe7b25 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlansy000077500000000000000000000061571325016550400166640ustar00rootroot00000000000000--- :name: dlansy :md5sum: 78d7f9a5930b4f926c5af132c0fb33be :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlantb000077500000000000000000000071261325016550400166330ustar00rootroot00000000000000--- :name: dlantb :md5sum: e69b4aec54ed535659db6b5c4040807d :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlantp000077500000000000000000000062021325016550400166430ustar00rootroot00000000000000--- :name: dlantp :md5sum: 89c0a27d7546449efda1386a0b958f8b :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlantr000077500000000000000000000073241325016550400166530ustar00rootroot00000000000000--- :name: dlantr :md5sum: f11d9df4022a1ca2d33a5591fbe76955 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlanv2000077500000000000000000000046541325016550400165600ustar00rootroot00000000000000--- :name: dlanv2 :md5sum: c7c0b03a8957e1ba328eea9560c78752 :category: :subroutine :arguments: - a: :type: doublereal :intent: input/output - b: :type: doublereal :intent: input/output - c: :type: doublereal :intent: input/output - d: :type: doublereal :intent: input/output - rt1r: :type: doublereal :intent: output - rt1i: :type: doublereal :intent: output - rt2r: :type: doublereal :intent: output - rt2i: :type: doublereal :intent: output - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlapll000077500000000000000000000037211325016550400166340ustar00rootroot00000000000000--- :name: dlapll :md5sum: 08eb4ce7bfd3ce4c24db7b847d4d9b50 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlapmr000077500000000000000000000040251325016550400166410ustar00rootroot00000000000000--- :name: dlapmr :md5sum: b24c98083dc638c7e586e2e99b4a3ff4 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlapmt000077500000000000000000000040301325016550400166370ustar00rootroot00000000000000--- :name: dlapmt :md5sum: 7e42e3f49a708615b1f14ee2a2897663 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlapy2000077500000000000000000000013051325016550400165530ustar00rootroot00000000000000--- :name: dlapy2 :md5sum: b3aaae9d309eec4c8fefd63e3e59e662 :category: :function :type: doublereal :arguments: - x: :type: doublereal :intent: input - y: :type: doublereal :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlapy3000077500000000000000000000014531325016550400165600ustar00rootroot00000000000000--- :name: dlapy3 :md5sum: c296e214a3a458bf2d8aca2d8a9f6f10 :category: :function :type: doublereal :arguments: - x: :type: doublereal :intent: input - y: :type: doublereal :intent: input - z: :type: doublereal :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqgb000077500000000000000000000074651325016550400166270ustar00rootroot00000000000000--- :name: dlaqgb :md5sum: 3e680371f6b032c8b947d3a6023a369f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqge000077500000000000000000000062711325016550400166240ustar00rootroot00000000000000--- :name: dlaqge :md5sum: b14c9cc959d1e11f7142942dbe096cdd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqp2000077500000000000000000000067601325016550400165550ustar00rootroot00000000000000--- :name: dlaqp2 :md5sum: 164cf40c4a8b2b2a7c734e7cadfbff68 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqps000077500000000000000000000102361325016550400166470ustar00rootroot00000000000000--- :name: dlaqps :md5sum: cd53ffb1ef39ff1b9a7f507f393e88d5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - kb - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - auxv: :type: doublereal :intent: input/output :dims: - nb - f: :type: doublereal :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqr0000077500000000000000000000216021325016550400165450ustar00rootroot00000000000000--- :name: dlaqr0 :md5sum: be8e4fe92e20cfc56b54b4a1ae53db3d :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - ihi - wi: :type: doublereal :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqr1000077500000000000000000000042351325016550400165510ustar00rootroot00000000000000--- :name: dlaqr1 :md5sum: ad34e252476d8fc18eea40e0f25e76ec :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: doublereal :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - sr1: :type: doublereal :intent: input - si1: :type: doublereal :intent: input - sr2: :type: doublereal :intent: input - si2: :type: doublereal :intent: input - v: :type: doublereal :intent: output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqr2000077500000000000000000000206661325016550400165600ustar00rootroot00000000000000--- :name: dlaqr2 :md5sum: e0c45302be6c32704dcfaf7b0ad95ca3 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: doublereal :intent: output :dims: - MAX(1,kbot) - si: :type: doublereal :intent: output :dims: - MAX(1,kbot) - v: :type: doublereal :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublereal :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublereal :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqr3000077500000000000000000000203301325016550400165450ustar00rootroot00000000000000--- :name: dlaqr3 :md5sum: 6e3a9343765ecb5f586856edd3fb6ba7 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: doublereal :intent: output :dims: - MAX(1,kbot) - si: :type: doublereal :intent: output :dims: - MAX(1,kbot) - v: :type: doublereal :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublereal :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublereal :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqr4000077500000000000000000000216021325016550400165510ustar00rootroot00000000000000--- :name: dlaqr4 :md5sum: d8ba6b6e3c95815f0a98bf31c88ffd41 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - ihi - wi: :type: doublereal :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqr5000077500000000000000000000167551325016550400165670ustar00rootroot00000000000000--- :name: dlaqr5 :md5sum: 7e0db3e70152db066243f2fdafb92b99 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - sr: :type: doublereal :intent: input/output :dims: - nshfts - si: :type: doublereal :intent: input/output :dims: - nshfts - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: doublereal :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: doublereal :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublereal :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: doublereal :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldz: n ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqsb000077500000000000000000000064611325016550400166360ustar00rootroot00000000000000--- :name: dlaqsb :md5sum: c7dc33589acebc95caeb49a34f486200 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqsp000077500000000000000000000054211325016550400166470ustar00rootroot00000000000000--- :name: dlaqsp :md5sum: d4a0f98e745846989812a681a1028e71 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqsy000077500000000000000000000060541325016550400166630ustar00rootroot00000000000000--- :name: dlaqsy :md5sum: 13b532db3d981114daeb56ec93631e26 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaqtr000077500000000000000000000102531325016550400166510ustar00rootroot00000000000000--- :name: dlaqtr :md5sum: 3ddbfae11a027af905ef99908a20b4bc :category: :subroutine :arguments: - ltran: :type: logical :intent: input - lreal: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - n - w: :type: doublereal :intent: input - scale: :type: doublereal :intent: output - x: :type: doublereal :intent: input/output :dims: - 2*n - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlar1v000077500000000000000000000146271325016550400165640ustar00rootroot00000000000000--- :name: dlar1v :md5sum: 6322bae9cfb9228c90b6dd34a2408183 :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - l: :type: doublereal :intent: input :dims: - n-1 - ld: :type: doublereal :intent: input :dims: - n-1 - lld: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - gaptol: :type: doublereal :intent: input - z: :type: doublereal :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: doublereal :intent: output - mingma: :type: doublereal :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: doublereal :intent: output - resid: :type: doublereal :intent: output - rqcorr: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlar2v000077500000000000000000000046331325016550400165610ustar00rootroot00000000000000--- :name: dlar2v :md5sum: 6fb47caf55cd693b64352d0bddea77e7 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - z: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarf000077500000000000000000000050421325016550400164520ustar00rootroot00000000000000--- :name: dlarf :md5sum: 8e2a3aa760cbf5b5a973bac159402732 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarfb000077500000000000000000000076761325016550400166330ustar00rootroot00000000000000--- :name: dlarfb :md5sum: a20fc3a5ff2f6f880a322c5402f64de1 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/dlarfg000077500000000000000000000036421325016550400166250ustar00rootroot00000000000000--- :name: dlarfg :md5sum: b49ee6b8b32b95df33c1bc8b264b644c :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input/output - x: :type: doublereal :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarfgp000077500000000000000000000036231325016550400170040ustar00rootroot00000000000000--- :name: dlarfgp :md5sum: 89a34e78357d879182ce8b4d6c766cdb :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input/output - x: :type: doublereal :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarft000077500000000000000000000107651325016550400166460ustar00rootroot00000000000000--- :name: dlarft :md5sum: 9da79581d3d17e4f1df0d934e54c55b6 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - t: :type: doublereal :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarfx000077500000000000000000000046401325016550400166450ustar00rootroot00000000000000--- :name: dlarfx :md5sum: 108ce4a0efb7326ffa867e146ae4ee94 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - m - tau: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlargv000077500000000000000000000037571325016550400166540ustar00rootroot00000000000000--- :name: dlargv :md5sum: af0943ce2244e6b1a773daa080bf4a76 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarnv000077500000000000000000000033571325016550400166570ustar00rootroot00000000000000--- :name: dlarnv :md5sum: dad4be46eef825d7419dd9092100cb4d :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarra000077500000000000000000000064751325016550400166420ustar00rootroot00000000000000--- :name: dlarra :md5sum: 417ebdba02d74121e10b2f2e71e95dba :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - e2: :type: doublereal :intent: input/output :dims: - n - spltol: :type: doublereal :intent: input - tnrm: :type: doublereal :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarrb000077500000000000000000000124611325016550400166330ustar00rootroot00000000000000--- :name: dlarrb :md5sum: 94581ce130ae520a534c65b282147970 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - lld: :type: doublereal :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - offset: :type: integer :intent: input - w: :type: doublereal :intent: input/output :dims: - n - wgap: :type: doublereal :intent: input/output :dims: - n-1 - werr: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: doublereal :intent: input - spdiam: :type: doublereal :intent: input - twist: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarrc000077500000000000000000000054271325016550400166400ustar00rootroot00000000000000--- :name: dlarrc :md5sum: 2d81dc9eb77d1fa80fe1708beeb85b08 :category: :subroutine :arguments: - jobt: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n - pivmin: :type: doublereal :intent: input - eigcnt: :type: integer :intent: output - lcnt: :type: integer :intent: output - rcnt: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarrd000077500000000000000000000257231325016550400166420ustar00rootroot00000000000000--- :name: dlarrd :md5sum: 1c6e49f591c6b2ec7416a44a5da7f9c7 :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - gers: :type: doublereal :intent: input :dims: - 2*n - reltol: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - e2: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - nsplit: :type: integer :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - werr: :type: doublereal :intent: output :dims: - n - wl: :type: doublereal :intent: output - wu: :type: doublereal :intent: output - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarre000077500000000000000000000223161325016550400166360ustar00rootroot00000000000000--- :name: dlarre :md5sum: 9747783e17f3023e920adbd7f058f053 :category: :subroutine :arguments: - range: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input/output - vu: :type: doublereal :intent: input/output - il: :type: integer :intent: input - iu: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - e2: :type: doublereal :intent: input/output :dims: - n - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - spltol: :type: doublereal :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - werr: :type: doublereal :intent: output :dims: - n - wgap: :type: doublereal :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - gers: :type: doublereal :intent: output :dims: - 2*n - pivmin: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 6*n - iwork: :type: integer :intent: workspace :dims: - 5*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurred 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" ruby-lapack-1.8.1/dev/defs/dlarrf000077500000000000000000000116561325016550400166440ustar00rootroot00000000000000--- :name: dlarrf :md5sum: df72f10d35d5993e0a6caea1cd27a6a6 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - l: :type: doublereal :intent: input :dims: - n-1 - ld: :type: doublereal :intent: input :dims: - n-1 - clstrt: :type: integer :intent: input - clend: :type: integer :intent: input - w: :type: doublereal :intent: input :dims: - clend-clstrt+1 - wgap: :type: doublereal :intent: input/output :dims: - clend-clstrt+1 - werr: :type: doublereal :intent: input :dims: - clend-clstrt+1 - spdiam: :type: doublereal :intent: input - clgapl: :type: doublereal :intent: input - clgapr: :type: doublereal :intent: input - pivmin: :type: doublereal :intent: input - sigma: :type: doublereal :intent: output - dplus: :type: doublereal :intent: output :dims: - n - lplus: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 split).\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" ruby-lapack-1.8.1/dev/defs/dlarrj000077500000000000000000000101171325016550400166370ustar00rootroot00000000000000--- :name: dlarrj :md5sum: 2a08a838ca5660f3b1cf1b9237f3741e :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e2: :type: doublereal :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol: :type: doublereal :intent: input - offset: :type: integer :intent: input - w: :type: doublereal :intent: input/output :dims: - n - werr: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: doublereal :intent: input - spdiam: :type: doublereal :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarrk000077500000000000000000000062451325016550400166470ustar00rootroot00000000000000--- :name: dlarrk :md5sum: 4e0b3e510031faaddb890af5e08e89a2 :category: :subroutine :arguments: - n: :type: integer :intent: input - iw: :type: integer :intent: input - gl: :type: doublereal :intent: input - gu: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e2: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - reltol: :type: doublereal :intent: input - w: :type: doublereal :intent: output - werr: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarrr000077500000000000000000000036231325016550400166530ustar00rootroot00000000000000--- :name: dlarrr :md5sum: aaf8ba40b9ad39ee862cbb6d215c9186 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarrv000077500000000000000000000222661325016550400166630ustar00rootroot00000000000000--- :name: dlarrv :md5sum: 955488910714829a06c9ad0b196024a4 :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - d: :type: doublereal :intent: input/output :dims: - n - l: :type: doublereal :intent: input/output :dims: - n - pivmin: :type: doublereal :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: doublereal :intent: input - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - w: :type: doublereal :intent: input/output :dims: - n - werr: :type: doublereal :intent: input/output :dims: - n - wgap: :type: doublereal :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: doublereal :intent: input :dims: - 2*n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " 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 split.) 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 occurred 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" ruby-lapack-1.8.1/dev/defs/dlarscl2000077500000000000000000000030511325016550400170660ustar00rootroot00000000000000--- :name: dlarscl2 :md5sum: ccf9a7110b886c2acac2362579620076 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlartg000077500000000000000000000035541325016550400166450ustar00rootroot00000000000000--- :name: dlartg :md5sum: bb5487cb5406058ab57b2e64f937ebe7 :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output - r: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlartgp000077500000000000000000000033561325016550400170250ustar00rootroot00000000000000--- :name: dlartgp :md5sum: bed8b61858c5189bd7a27d2f840c6ce8 :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output - r: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlartgs000077500000000000000000000030761325016550400170270ustar00rootroot00000000000000--- :name: dlartgs :md5sum: bf0292e885c671bdbb8046966e02a27e :category: :subroutine :arguments: - x: :type: doublereal :intent: input - y: :type: doublereal :intent: input - sigma: :type: doublereal :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlartv000077500000000000000000000042301325016550400166540ustar00rootroot00000000000000--- :name: dlartv :md5sum: 4f0bf90dcdf7a26f49b5a73714cdf127 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaruv000077500000000000000000000034621325016550400166630ustar00rootroot00000000000000--- :name: dlaruv :md5sum: 5f925de019c10838c63b3fb8bb460f32 :category: :subroutine :arguments: - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarz000077500000000000000000000057671325016550400165140ustar00rootroot00000000000000--- :name: dlarz :md5sum: 61bd58498447c9dba40be54132c17b25 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlarzb000077500000000000000000000103621325016550400166410ustar00rootroot00000000000000--- :name: dlarzb :md5sum: f96a6fc175b682aa86c9a5b8a426ef27 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/dlarzt000077500000000000000000000123151325016550400166630ustar00rootroot00000000000000--- :name: dlarzt :md5sum: 794da30b757b5da1ded2c6c9124f7150 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - t: :type: doublereal :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlas2000077500000000000000000000041521325016550400163700ustar00rootroot00000000000000--- :name: dlas2 :md5sum: 6ae427644021d52d561acf40d2ec605c :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - h: :type: doublereal :intent: input - ssmin: :type: doublereal :intent: output - ssmax: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlascl000077500000000000000000000064031325016550400166260ustar00rootroot00000000000000--- :name: dlascl :md5sum: c116ad39650764c8b0fe2bbf035ba7a3 :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: doublereal :intent: input - cto: :type: doublereal :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlascl2000077500000000000000000000030201325016550400167000ustar00rootroot00000000000000--- :name: dlascl2 :md5sum: 303b57afa464faf1740b95059b092c65 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd0000077500000000000000000000102451325016550400165320ustar00rootroot00000000000000--- :name: dlasd0 :md5sum: 469c67fd3b988986d8c9fe190b5a3db7 :category: :subroutine :arguments: - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input :dims: - m-1 - u: :type: doublereal :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - smlsiz: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - (8 * n) - work: :type: doublereal :intent: workspace :dims: - (3 * pow(m,2) + 2 * m) - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldvt: n ldu: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd1000077500000000000000000000142251325016550400165350ustar00rootroot00000000000000--- :name: dlasd1 :md5sum: 4f6a6e622373feee99a1d18bb5f55bec :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - alpha: :type: doublereal :intent: input/output - beta: :type: doublereal :intent: input/output - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - idxq: :type: integer :intent: output :dims: - n - iwork: :type: integer :intent: workspace :dims: - 4 * n - work: :type: doublereal :intent: workspace :dims: - 3*pow(m,2) + 2*m - info: :type: integer :intent: output :substitutions: m: n + sqre n: nl+nr+1 :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/dlasd2000077500000000000000000000211011325016550400165250ustar00rootroot00000000000000--- :name: dlasd2 :md5sum: 2f07ad46ba203eded0d5d52c02cc3361 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: doublereal :intent: input/output :dims: - n - z: :type: doublereal :intent: output :dims: - n - alpha: :type: doublereal :intent: input - beta: :type: doublereal :intent: input - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - dsigma: :type: doublereal :intent: output :dims: - n - u2: :type: doublereal :intent: output :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt2: :type: doublereal :intent: output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxp: :type: integer :intent: workspace :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxc: :type: integer :intent: output :dims: - n - idxq: :type: integer :intent: input/output :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldu2: n ldvt2: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd3000077500000000000000000000144551325016550400165440ustar00rootroot00000000000000--- :name: dlasd3 :md5sum: eea845f53351b22e245c27f4d81cd078 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - k - q: :type: doublereal :intent: workspace :dims: - ldq - k - ldq: :type: integer :intent: input - dsigma: :type: doublereal :intent: input :dims: - k - u: :type: doublereal :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - u2: :type: doublereal :intent: input/output :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - vt2: :type: doublereal :intent: input/output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxc: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - z: :type: doublereal :intent: input :dims: - k - info: :type: integer :intent: output :substitutions: m: n + sqre ldq: k n: nl + nr + 1 ldu2: n ldvt: n ldvt2: n ldu: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd4000077500000000000000000000073021325016550400165360ustar00rootroot00000000000000--- :name: dlasd4 :md5sum: f02b36b4a85646e4e01e1dd6445ec7fe :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - z: :type: doublereal :intent: input :dims: - n - delta: :type: doublereal :intent: output :dims: - n - rho: :type: doublereal :intent: input - sigma: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd5000077500000000000000000000046501325016550400165420ustar00rootroot00000000000000--- :name: dlasd5 :md5sum: a3ba28af47ea722e3d88224bb102319d :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - "2" - z: :type: doublereal :intent: input :dims: - "2" - delta: :type: doublereal :intent: output :dims: - "2" - rho: :type: doublereal :intent: input - dsigma: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - "2" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd6000077500000000000000000000245271325016550400165500ustar00rootroot00000000000000--- :name: dlasd6 :md5sum: d01a531ca94d767a226f40498502e8dd :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - nl+nr+1 - vf: :type: doublereal :intent: input/output :dims: - m - vl: :type: doublereal :intent: input/output :dims: - m - alpha: :type: doublereal :intent: input/output - beta: :type: doublereal :intent: input/output - idxq: :type: integer :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: doublereal :intent: output :dims: - ldgnum - "2" - difl: :type: doublereal :intent: output :dims: - n - difr: :type: doublereal :intent: output :dims: - "icompq == 1 ? ldgnum : icompq == 0 ? n : 0" - "icompq == 1 ? 2 : 0" - z: :type: doublereal :intent: output :dims: - m - k: :type: integer :intent: output - c: :type: doublereal :intent: output - s: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4 * m - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: m: n + sqre n: nl + nr + 1 ldgnum: n ldgcol: n :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/dlasd7000077500000000000000000000205031325016550400165370ustar00rootroot00000000000000--- :name: dlasd7 :md5sum: f4a96aafe698a9fe1dc5bee822c506d3 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: doublereal :intent: input/output :dims: - n - z: :type: doublereal :intent: output :dims: - m - zw: :type: doublereal :intent: workspace :dims: - m - vf: :type: doublereal :intent: input/output :dims: - m - vfw: :type: doublereal :intent: workspace :dims: - m - vl: :type: doublereal :intent: input/output :dims: - m - vlw: :type: doublereal :intent: workspace :dims: - m - alpha: :type: doublereal :intent: input - beta: :type: doublereal :intent: input - dsigma: :type: doublereal :intent: output :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxp: :type: integer :intent: workspace :dims: - n - idxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - c: :type: doublereal :intent: output - s: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: ldgnum: n ldgcol: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasd8000077500000000000000000000113161325016550400165420ustar00rootroot00000000000000--- :name: dlasd8 :md5sum: da4e64c91be87e67d70f49ec5f695f5e :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - k - z: :type: doublereal :intent: input/output :dims: - k - vf: :type: doublereal :intent: input/output :dims: - k - vl: :type: doublereal :intent: input/output :dims: - k - difl: :type: doublereal :intent: output :dims: - k - difr: :type: doublereal :intent: output :dims: - "icompq == 1 ? lddifr : icompq == 0 ? k : 0" - "icompq == 1 ? 2 : 0" - lddifr: :type: integer :intent: input - dsigma: :type: doublereal :intent: input/output :dims: - k - work: :type: doublereal :intent: workspace :dims: - 3 * k - info: :type: integer :intent: output :substitutions: lddifr: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasda000077500000000000000000000224261325016550400166170ustar00rootroot00000000000000--- :name: dlasda :md5sum: a77fa77241c8f31a76eaef00f664e15a :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input :dims: - m-1 - u: :type: doublereal :intent: output :dims: - ldu - MAX(1,smlsiz) - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldu - smlsiz+1 - k: :type: integer :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - difl: :type: doublereal :intent: output :dims: - ldu - nlvl - difr: :type: doublereal :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? 2 * nlvl : 0" - z: :type: doublereal :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? nlvl : 0" - poles: :type: doublereal :intent: output :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: output :dims: - n - givcol: :type: integer :intent: output :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: output :dims: - ldgcol - nlvl - givnum: :type: doublereal :intent: output :dims: - ldu - 2 * nlvl - c: :type: doublereal :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - s: :type: doublereal :intent: output :dims: - "icompq==1 ? n : icompq==0 ? 1 : 0" - work: :type: doublereal :intent: workspace :dims: - 6 * n + (smlsiz + 1)*(smlsiz + 1) - iwork: :type: integer :intent: workspace :dims: - (7 * n) - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldu: n nlvl: floor(1.0/log(2.0)*log((double)n/smlsiz)) ldgcol: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasdq000077500000000000000000000146511325016550400166400ustar00rootroot00000000000000--- :name: dlasdq :md5sum: c377895c7b312038c22d75f7469b1c8c :category: :subroutine :arguments: - uplo: :type: char :intent: input - sqre: :type: integer :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - "sqre==0 ? n-1 : sqre==1 ? n : 0" - vt: :type: doublereal :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 whether 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" ruby-lapack-1.8.1/dev/defs/dlasdt000077500000000000000000000036411325016550400166400ustar00rootroot00000000000000--- :name: dlasdt :md5sum: c087d4c2a38cb314111522d50756d606 :category: :subroutine :arguments: - n: :type: integer :intent: input - lvl: :type: integer :intent: output - nd: :type: integer :intent: output - inode: :type: integer :intent: output :dims: - MAX(1,n) - ndiml: :type: integer :intent: output :dims: - MAX(1,n) - ndimr: :type: integer :intent: output :dims: - MAX(1,n) - msub: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaset000077500000000000000000000050121325016550400166330ustar00rootroot00000000000000--- :name: dlaset :md5sum: c2f6317581bca79e8eb4cd9e8db8f3c7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - beta: :type: doublereal :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasq1000077500000000000000000000047551325016550400165610ustar00rootroot00000000000000--- :name: dlasq1 :md5sum: 64432270af33eae03a6a5fd907dae092 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasq2000077500000000000000000000056171325016550400165600ustar00rootroot00000000000000--- :name: dlasq2 :md5sum: dc76333ff510f8712b38bba549479bf4 :category: :subroutine :arguments: - n: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasq3000077500000000000000000000066351325016550400165620ustar00rootroot00000000000000--- :name: dlasq3 :md5sum: 0e9fda6509d5400632d45ebec7f96a65 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input/output - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input/output - dmin: :type: doublereal :intent: output - sigma: :type: doublereal :intent: output - desig: :type: doublereal :intent: input/output - qmax: :type: doublereal :intent: input - nfail: :type: integer :intent: output - iter: :type: integer :intent: output - ndiv: :type: integer :intent: output - ieee: :type: logical :intent: input - ttype: :type: integer :intent: input/output - dmin1: :type: doublereal :intent: input/output - dmin2: :type: doublereal :intent: input/output - dn: :type: doublereal :intent: input/output - dn1: :type: doublereal :intent: input/output - dn2: :type: doublereal :intent: input/output - g: :type: doublereal :intent: input/output - tau: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasq4000077500000000000000000000046271325016550400165620ustar00rootroot00000000000000--- :name: dlasq4 :md5sum: 6d8b1df65fc2a9a01be27c77f4c07567 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - n0in: :type: integer :intent: input - dmin: :type: doublereal :intent: input - dmin1: :type: doublereal :intent: input - dmin2: :type: doublereal :intent: input - dn: :type: doublereal :intent: input - dn1: :type: doublereal :intent: input - dn2: :type: doublereal :intent: input - tau: :type: doublereal :intent: output - ttype: :type: integer :intent: output - g: :type: real :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasq5000077500000000000000000000047451325016550400165640ustar00rootroot00000000000000--- :name: dlasq5 :md5sum: 3d03f3e888c881f172d8092734679c9d :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - tau: :type: doublereal :intent: input - dmin: :type: doublereal :intent: output - dmin1: :type: doublereal :intent: output - dmin2: :type: doublereal :intent: output - dn: :type: doublereal :intent: output - dnm1: :type: doublereal :intent: output - dnm2: :type: doublereal :intent: output - ieee: :type: logical :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasq6000077500000000000000000000045251325016550400165610ustar00rootroot00000000000000--- :name: dlasq6 :md5sum: 51937f03f827ecc2ba8f5b8564d50417 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - dmin: :type: doublereal :intent: output - dmin1: :type: doublereal :intent: output - dmin2: :type: doublereal :intent: output - dn: :type: doublereal :intent: output - dnm1: :type: doublereal :intent: output - dnm2: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasr000077500000000000000000000140711325016550400164710ustar00rootroot00000000000000--- :name: dlasr :md5sum: b4a6611d98b6eae9b7f7b00cae25a5e9 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - m-1 - s: :type: doublereal :intent: input :dims: - m-1 - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasrt000077500000000000000000000027411325016550400166560ustar00rootroot00000000000000--- :name: dlasrt :md5sum: 3da55e931ca1aaf18ac9c8170eacfd4e :category: :subroutine :arguments: - id: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlassq000077500000000000000000000041461325016550400166550ustar00rootroot00000000000000--- :name: dlassq :md5sum: 3c1c556bdf9d5d6e44e32c35fd990d30 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: doublereal :intent: input/output - sumsq: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasv2000077500000000000000000000061571325016550400165650ustar00rootroot00000000000000--- :name: dlasv2 :md5sum: 9337b1a710d99f92d83bed784d02e670 :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - h: :type: doublereal :intent: input - ssmin: :type: doublereal :intent: output - ssmax: :type: doublereal :intent: output - snr: :type: doublereal :intent: output - csr: :type: doublereal :intent: output - snl: :type: doublereal :intent: output - csl: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlaswp000077500000000000000000000045121325016550400166550ustar00rootroot00000000000000--- :name: dlaswp :md5sum: 836b13a675719254b74dc6b844e95cd1 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasy2000077500000000000000000000100741325016550400165610ustar00rootroot00000000000000--- :name: dlasy2 :md5sum: 88846cd9774931667a402f668ac7bcbe :category: :subroutine :arguments: - ltranl: :type: logical :intent: input - ltranr: :type: logical :intent: input - isgn: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - tl: :type: doublereal :intent: input :dims: - ldtl - "2" - ldtl: :type: integer :intent: input - tr: :type: doublereal :intent: input :dims: - ldtr - "2" - ldtr: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - scale: :type: doublereal :intent: output - x: :type: doublereal :intent: output :dims: - ldx - "2" - ldx: :type: integer :intent: input - xnorm: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n1) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlasyf000077500000000000000000000106061325016550400166460ustar00rootroot00000000000000--- :name: dlasyf :md5sum: a8454c0cdaacfc25f0e790f47e4824f1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: doublereal :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlat2s000077500000000000000000000050401325016550400165510ustar00rootroot00000000000000--- :name: dlat2s :md5sum: 14fb3f483c9e3e8966201c93a8b4399b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: real :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,n) :fortran_help: " 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 conversion 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" ruby-lapack-1.8.1/dev/defs/dlatbs000077500000000000000000000170171325016550400166400ustar00rootroot00000000000000--- :name: dlatbs :md5sum: 9350a6e18496c8737cb00c53bba4cc08 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlatdf000077500000000000000000000115431325016550400166230ustar00rootroot00000000000000--- :name: dlatdf :md5sum: 69cfce3953f1837f451afd56bf000e43 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: doublereal :intent: input/output :dims: - n - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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 chosen 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" ruby-lapack-1.8.1/dev/defs/dlatps000077500000000000000000000162131325016550400166530ustar00rootroot00000000000000--- :name: dlatps :md5sum: 14110c3ace99afb7ed820151dddf667f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - x: :type: doublereal :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlatrd000077500000000000000000000140771325016550400166440ustar00rootroot00000000000000--- :name: dlatrd :md5sum: b6751dfd08ecd201d434b7f4b939e5b4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - w: :type: doublereal :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlatrs000077500000000000000000000170221325016550400166540ustar00rootroot00000000000000--- :name: dlatrs :md5sum: 78957566bfa0909d05e8e96786331be9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlatrz000077500000000000000000000066501325016550400166700ustar00rootroot00000000000000--- :name: dlatrz :md5sum: 29240b38847f5fec70a609188c5ec3c5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - m - work: :type: doublereal :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlatzm000077500000000000000000000072461325016550400166650ustar00rootroot00000000000000--- :name: dlatzm :md5sum: 93a8893a5409108190967bd55dcd6d6d :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublereal :intent: input - c1: :type: doublereal :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: doublereal :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlauu2000077500000000000000000000041501325016550400165550ustar00rootroot00000000000000--- :name: dlauu2 :md5sum: 4f0fa7e3d7bb575ad8296112c8ff7b7f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dlauum000077500000000000000000000041461325016550400166550ustar00rootroot00000000000000--- :name: dlauum :md5sum: f5db6017186c241df76a0021dec24cdc :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dopgtr000077500000000000000000000045251325016550400166660ustar00rootroot00000000000000--- :name: dopgtr :md5sum: 3be95896182d344b40b94e108282b151 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - tau: :type: doublereal :intent: input :dims: - ldtau - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dopmtr000077500000000000000000000071671325016550400167010ustar00rootroot00000000000000--- :name: dopmtr :md5sum: 663f65160cdb7949b61c331713b3a943 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - m*(m+1)/2 - tau: :type: doublereal :intent: input :dims: - m-1 - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorbdb000077500000000000000000000216521325016550400166230ustar00rootroot00000000000000--- :name: dorbdb :md5sum: 6a768cd2fe5db676bc79606b0d918596 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublereal :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: doublereal :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: doublereal :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: doublereal :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - q - phi: :type: doublereal :intent: output :dims: - q-1 - taup1: :type: doublereal :intent: output :dims: - p - taup2: :type: doublereal :intent: output :dims: - m-p - tauq1: :type: doublereal :intent: output :dims: - q - tauq2: :type: doublereal :intent: output :dims: - m-q - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorcsd000077500000000000000000000173111325016550400166420ustar00rootroot00000000000000--- :name: dorcsd :md5sum: 16a44e6711210545e42e19e9eb2e970f :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublereal :intent: input :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: doublereal :intent: input :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: doublereal :intent: input :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: doublereal :intent: input :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: doublereal :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: doublereal :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublereal :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: doublereal :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" 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" p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorg2l000077500000000000000000000044751325016550400165640ustar00rootroot00000000000000--- :name: dorg2l :md5sum: 3e5cd2233ef21406983948746d5b6aaf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorg2r000077500000000000000000000044711325016550400165660ustar00rootroot00000000000000--- :name: dorg2r :md5sum: af8c6ad7cd7df62846868e6258c386e0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgbr000077500000000000000000000105461325016550400166460ustar00rootroot00000000000000--- :name: dorgbr :md5sum: 77e112eb51464cf117c5be590352f159 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - MIN(m,k) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorghr000077500000000000000000000056621325016550400166570ustar00rootroot00000000000000--- :name: dorghr :md5sum: 05dfa3e4bb3b03cb3e2846680ed1ae05 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgl2000077500000000000000000000044361325016550400165610ustar00rootroot00000000000000--- :name: dorgl2 :md5sum: 6ba11f9817d8923212cda012b48b0806 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorglq000077500000000000000000000057301325016550400166560ustar00rootroot00000000000000--- :name: dorglq :md5sum: 312b7a0a9316ed4c8b1081726e032b69 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgql000077500000000000000000000057751325016550400166670ustar00rootroot00000000000000--- :name: dorgql :md5sum: 94580030c4ac4cba48c074ae5fc70b8d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgqr000077500000000000000000000057711325016550400166710ustar00rootroot00000000000000--- :name: dorgqr :md5sum: 10a83164d308f6d24d44e9831e4999ff :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgr2000077500000000000000000000044621325016550400165660ustar00rootroot00000000000000--- :name: dorgr2 :md5sum: 9ffcc258297972edf31797ab19274e52 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgrq000077500000000000000000000057541325016550400166720ustar00rootroot00000000000000--- :name: dorgrq :md5sum: e982525c706ceef56e0ecde091ae0481 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorgtr000077500000000000000000000055461325016550400166740ustar00rootroot00000000000000--- :name: dorgtr :md5sum: fcaca39eb500671fa5d4d41d70cf3fb2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorm2l000077500000000000000000000073211325016550400165630ustar00rootroot00000000000000--- :name: dorm2l :md5sum: bf848d9455fb1572cc2de061259422ae :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorm2r000077500000000000000000000073221325016550400165720ustar00rootroot00000000000000--- :name: dorm2r :md5sum: fab971af37bdf9192f838b2bc546173d :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormbr000077500000000000000000000141341325016550400166510ustar00rootroot00000000000000--- :name: dormbr :md5sum: b5ba35a95f74b550f64794efa893d8b7 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - MIN(nq,k) - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormhr000077500000000000000000000122641325016550400166610ustar00rootroot00000000000000--- :name: dormhr :md5sum: 1aa88be0d6f9f382347ae47d367d3cfc :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - m-1 - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dorml2000077500000000000000000000073541325016550400165710ustar00rootroot00000000000000--- :name: dorml2 :md5sum: bf58654a0eb1ae3bde80e6d4b318343f :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormlq000077500000000000000000000105731325016550400166650ustar00rootroot00000000000000--- :name: dormlq :md5sum: 8dfec4368a6a339237ffb44f3b838c49 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormql000077500000000000000000000105401325016550400166570ustar00rootroot00000000000000--- :name: dormql :md5sum: 91204df0ad361c3d664f21c97a977882 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormqr000077500000000000000000000105411325016550400166660ustar00rootroot00000000000000--- :name: dormqr :md5sum: 3680363f39cc4d2d574d217d1252ceeb :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormr2000077500000000000000000000073531325016550400165760ustar00rootroot00000000000000--- :name: dormr2 :md5sum: 08b4812e38d10b5056d4fbd87207a314 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormr3000077500000000000000000000111551325016550400165720ustar00rootroot00000000000000--- :name: dormr3 :md5sum: 5ee7280aa9deca5f92422e6d0bdeb1f2 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormrq000077500000000000000000000105721325016550400166720ustar00rootroot00000000000000--- :name: dormrq :md5sum: 076a38b2e29790a32e3e67694f2b9668 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormrz000077500000000000000000000115111325016550400166750ustar00rootroot00000000000000--- :name: dormrz :md5sum: b7420b7de5854d706c94fac76154c6d5 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dormtr000077500000000000000000000117211325016550400166720ustar00rootroot00000000000000--- :name: dormtr :md5sum: 977d8beedb08b5451d60dad11f963659 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - m-1 - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbcon000077500000000000000000000060451325016550400166330ustar00rootroot00000000000000--- :name: dpbcon :md5sum: 20d0a20dbd1b200d211eeeb871142b23 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbequ000077500000000000000000000063031325016550400166430ustar00rootroot00000000000000--- :name: dpbequ :md5sum: 0bbb9cf6bd18888eaa8a1e40f750a9a9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbrfs000077500000000000000000000121151325016550400166410ustar00rootroot00000000000000--- :name: dpbrfs :md5sum: 8b7dd205a80433495815f47866c016f7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbstf000077500000000000000000000076521325016550400166550ustar00rootroot00000000000000--- :name: dpbstf :md5sum: 5a40047148b7bdd37c15d29462a47190 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbsv000077500000000000000000000114321325016550400165000ustar00rootroot00000000000000--- :name: dpbsv :md5sum: a3c3e19a85e1eb645e99446b955890e8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbsvx000077500000000000000000000276571325016550400167100ustar00rootroot00000000000000--- :name: dpbsvx :md5sum: 8391174b1809b05ffa196bf9a0d4a47a :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbtf2000077500000000000000000000071261325016550400165500ustar00rootroot00000000000000--- :name: dpbtf2 :md5sum: a0c868c2ec6bdfb965b1e3b3e37bf6f3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbtrf000077500000000000000000000067631325016550400166560ustar00rootroot00000000000000--- :name: dpbtrf :md5sum: 6355622b2a30fa00a4fe3d46a1c18912 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpbtrs000077500000000000000000000061261325016550400166640ustar00rootroot00000000000000--- :name: dpbtrs :md5sum: a666157203f207f22114152a99a262ce :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpftrf000077500000000000000000000141421325016550400166500ustar00rootroot00000000000000--- :name: dpftrf :md5sum: 3fc77e15efea7d6ef9bac22a903fe147 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpftri000077500000000000000000000135061325016550400166560ustar00rootroot00000000000000--- :name: dpftri :md5sum: 60ad689ddf94971f01ab70b0fe6ff89c :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpftrs000077500000000000000000000132051325016550400166640ustar00rootroot00000000000000--- :name: dpftrs :md5sum: 7346bc2529481adfa1f5429620050f99 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpocon000077500000000000000000000047461325016550400166560ustar00rootroot00000000000000--- :name: dpocon :md5sum: 19c40cce9c2a922eb3d8ee1ae6cd2d5a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpoequ000077500000000000000000000050661325016550400166650ustar00rootroot00000000000000--- :name: dpoequ :md5sum: 858ca9e43e3ae192a06d9709d4c8242f :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpoequb000077500000000000000000000050701325016550400170220ustar00rootroot00000000000000--- :name: dpoequb :md5sum: 8d069074f0a04dd639f60982c9143567 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dporfs000077500000000000000000000115501325016550400166600ustar00rootroot00000000000000--- :name: dporfs :md5sum: b4307ba92a3d50b996c44d29f72b64d3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dporfsx000077500000000000000000000370771325016550400170640ustar00rootroot00000000000000--- :name: dporfsx :md5sum: 4552fe053ceaeaedf9f28e3f06ea1182 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dposv000077500000000000000000000070741325016550400165240ustar00rootroot00000000000000--- :name: dposv :md5sum: 3bed0f9f43c482181fa639e2e8ece7ae :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dposvx000077500000000000000000000257141325016550400167150ustar00rootroot00000000000000--- :name: dposvx :md5sum: c2a250ab29628cdb18458b228833428f :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dposvxx000077500000000000000000000505771325016550400171120ustar00rootroot00000000000000--- :name: dposvxx :md5sum: 3fd4b03e21b01e3b820125993ffeaee5 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/dpotf2000077500000000000000000000047241325016550400165660ustar00rootroot00000000000000--- :name: dpotf2 :md5sum: a622d364e9e8716c0a7f1c5077370930 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpotrf000077500000000000000000000045751325016550400166720ustar00rootroot00000000000000--- :name: dpotrf :md5sum: d423e0b564d01b7b1609bb5561b93073 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpotri000077500000000000000000000041371325016550400166670ustar00rootroot00000000000000--- :name: dpotri :md5sum: 2c5bbee2b4cacacf2af6cf4a23801249 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpotrs000077500000000000000000000042241325016550400166760ustar00rootroot00000000000000--- :name: dpotrs :md5sum: d5099d9bfdde3ecc9937572a960308cb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dppcon000077500000000000000000000051641325016550400166520ustar00rootroot00000000000000--- :name: dppcon :md5sum: 3736fd97dc2539bc118db306bfb573fb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dppequ000077500000000000000000000054551325016550400166700ustar00rootroot00000000000000--- :name: dppequ :md5sum: 62f6b4c55adfca98e81cfdd929796b64 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpprfs000077500000000000000000000110251325016550400166560ustar00rootroot00000000000000--- :name: dpprfs :md5sum: 7b677d919e716eb66e39a459092c0669 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dppsv000077500000000000000000000075761325016550400165340ustar00rootroot00000000000000--- :name: dppsv :md5sum: 05812066fff4498bbd8b9748ba91010d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dppsvx000077500000000000000000000260741325016550400167160ustar00rootroot00000000000000--- :name: dppsvx :md5sum: 2398de467fb49a54f33f13d43fb8e145 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpptrf000077500000000000000000000051621325016550400166640ustar00rootroot00000000000000--- :name: dpptrf :md5sum: 114d74d68f2338940fdfcbbc9fe314c0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpptri000077500000000000000000000036461325016550400166740ustar00rootroot00000000000000--- :name: dpptri :md5sum: aa52068aa972b2b1a3d2d96115563353 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpptrs000077500000000000000000000052221325016550400166760ustar00rootroot00000000000000--- :name: dpptrs :md5sum: e7c3946ec34bb6e52033f533f20b69ea :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpstf2000077500000000000000000000070171325016550400165700ustar00rootroot00000000000000--- :name: dpstf2 :md5sum: a3c2b199ffdc016a07d33dd0e50b9821 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpstrf000077500000000000000000000070151325016550400166660ustar00rootroot00000000000000--- :name: dpstrf :md5sum: 4601a86524330e102c2ffe6bf56c1149 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dptcon000077500000000000000000000050231325016550400166500ustar00rootroot00000000000000--- :name: dptcon :md5sum: 333dd6c839252d776031995183b815cc :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpteqr000077500000000000000000000105171325016550400166640ustar00rootroot00000000000000--- :name: dpteqr :md5sum: 82a196d2a9d89768456560591eed50c9 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dptrfs000077500000000000000000000101171325016550400166630ustar00rootroot00000000000000--- :name: dptrfs :md5sum: 39ea43178ed941789a2071e466d3b8b6 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - df: :type: doublereal :intent: input :dims: - n - ef: :type: doublereal :intent: input :dims: - n-1 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dptsv000077500000000000000000000057261325016550400165330ustar00rootroot00000000000000--- :name: dptsv :md5sum: 8adf057f5fcd9d544d11e80771debc24 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dptsvx000077500000000000000000000164621325016550400167220ustar00rootroot00000000000000--- :name: dptsvx :md5sum: f1a2d0ffc60d33704538dbaf610529e1 :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - df: :type: doublereal :intent: input/output :dims: - n - ef: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpttrf000077500000000000000000000037641325016550400166760ustar00rootroot00000000000000--- :name: dpttrf :md5sum: 203e7bbfdbd7f2634ace2a157d4cb178 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dpttrs000077500000000000000000000053361325016550400167100ustar00rootroot00000000000000--- :name: dpttrs :md5sum: 4df62154d25e780b1accac29911e5aef :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dptts2000077500000000000000000000044711325016550400166070ustar00rootroot00000000000000--- :name: dptts2 :md5sum: e107a9943c6e670481084e9260cc9f12 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/drscl000077500000000000000000000026251325016550400164750ustar00rootroot00000000000000--- :name: drscl :md5sum: f5c221f426610c222a5048da51a491d9 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: doublereal :intent: input - sx: :type: doublereal :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbev000077500000000000000000000074261325016550400164750ustar00rootroot00000000000000--- :name: dsbev :md5sum: 0ca5c28ae2889fbdbe1f84fad527d165 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbevd000077500000000000000000000143121325016550400166310ustar00rootroot00000000000000--- :name: dsbevd :md5sum: f4311645f4dac4d301b46deb5fdcd849 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbevx000077500000000000000000000202441325016550400166560ustar00rootroot00000000000000--- :name: dsbevx :md5sum: c54c0d69a5f4df0fc356205a4641b5ae :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbgst000077500000000000000000000077231325016550400166600ustar00rootroot00000000000000--- :name: dsbgst :md5sum: d2437ea90e45fe4864720cf3787add9d :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbgv000077500000000000000000000127001325016550400164660ustar00rootroot00000000000000--- :name: dsbgv :md5sum: 17fbadac3c6da4dce3f66fd5af4d631a :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbgvd000077500000000000000000000170321325016550400166350ustar00rootroot00000000000000--- :name: dsbgvd :md5sum: abed2add2591a833e7d03dc10381944d :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsbgvx000077500000000000000000000217551325016550400166700ustar00rootroot00000000000000--- :name: dsbgvx :md5sum: 1ee65cfeddf2efe1e17ddc18f8adf220 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - 7*n - iwork: :type: integer :intent: output :dims: - 5*n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :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" :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\ *\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" ruby-lapack-1.8.1/dev/defs/dsbtrd000077500000000000000000000101451325016550400166440ustar00rootroot00000000000000--- :name: dsbtrd :md5sum: f97e07edb1ff5355443723fc32114fa2 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsfrk000077500000000000000000000101631325016550400164730ustar00rootroot00000000000000--- :name: dsfrk :md5sum: 0c83f186d2d8e20fbde488e693408f71 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - "lsame_(&trans,\"N\") ? k : n" - lda: :type: integer :intent: input - beta: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - nt :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsgesv000077500000000000000000000140121325016550400166520ustar00rootroot00000000000000--- :name: dsgesv :md5sum: 37507bbdfd1407291f8640470f411a6e :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - nrhs - swork: :type: real :intent: workspace :dims: - n*(n+nrhs) - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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 successfully 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" ruby-lapack-1.8.1/dev/defs/dspcon000077500000000000000000000053451325016550400166560ustar00rootroot00000000000000--- :name: dspcon :md5sum: e621cc4d4a938054c58e6e583bb7bb66 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspev000077500000000000000000000065521325016550400165120ustar00rootroot00000000000000--- :name: dspev :md5sum: abbf7fb1bb1c2e05e3a416106fd62a7b :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspevd000077500000000000000000000134771325016550400166620ustar00rootroot00000000000000--- :name: dspevd :md5sum: 3bed418654a505888490fb1f28577d00 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspevx000077500000000000000000000162131325016550400166750ustar00rootroot00000000000000--- :name: dspevx :md5sum: a6eb1b7151c229ba06ead243be18d9d1 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspgst000077500000000000000000000051371325016550400166730ustar00rootroot00000000000000--- :name: dspgst :md5sum: 48403040935324240d0e4c768206ee8a :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - bp: :type: doublereal :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspgv000077500000000000000000000120001325016550400164750ustar00rootroot00000000000000--- :name: dspgv :md5sum: fa90c149e39cfb6acbcec1aec1f9ef15 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - bp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspgvd000077500000000000000000000160751325016550400166610ustar00rootroot00000000000000--- :name: dspgvd :md5sum: d8feb9f109926c26daeabbe88286ca5a :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - bp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspgvx000077500000000000000000000221451325016550400167000ustar00rootroot00000000000000--- :name: dspgvx :md5sum: f64e08142ffc3da2c4a946629754e8ad :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - bp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsposv000077500000000000000000000142721325016550400167050ustar00rootroot00000000000000--- :name: dsposv :md5sum: afe420b5c200deccb5aa7fc0f0c8cf39 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - nrhs - swork: :type: real :intent: workspace :dims: - n*(n+nrhs) - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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 successfully 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" ruby-lapack-1.8.1/dev/defs/dsprfs000077500000000000000000000115101325016550400166600ustar00rootroot00000000000000--- :name: dsprfs :md5sum: f0af4a880340cc82d7c68a365633767b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspsv000077500000000000000000000115561325016550400165300ustar00rootroot00000000000000--- :name: dspsv :md5sum: 0fac3d384951ed9358ca786e7d72fd2b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dspsvx000077500000000000000000000227401325016550400167150ustar00rootroot00000000000000--- :name: dspsvx :md5sum: 54ccdee08d1f02db7007bc1865c36951 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsptrd000077500000000000000000000077411325016550400166720ustar00rootroot00000000000000--- :name: dsptrd :md5sum: cf8f4de5c48cb0545e1cda0d8654c0d4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsptrf000077500000000000000000000115601325016550400166660ustar00rootroot00000000000000--- :name: dsptrf :md5sum: 6ecf609969698a72de25e3e961f876f8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsptri000077500000000000000000000047361325016550400167000ustar00rootroot00000000000000--- :name: dsptri :md5sum: 4b77efb779c649e38dd9815265e50086 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsptrs000077500000000000000000000046721325016550400167110ustar00rootroot00000000000000--- :name: dsptrs :md5sum: 410e8a2f4bef32f27f6075ab0bf5372c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstebz000077500000000000000000000217051325016550400166610ustar00rootroot00000000000000--- :name: dstebz :md5sum: 6043998408856bffa9d3ac796deb214d :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - m: :type: integer :intent: output - nsplit: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - isplit: :type: integer :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstedc000077500000000000000000000151171325016550400166340ustar00rootroot00000000000000--- :name: dstedc :md5sum: 419d32b31946e69cbb224aebb04054f0 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstegr000077500000000000000000000207661325016550400166640ustar00rootroot00000000000000--- :name: dstegr :md5sum: 5393f044bbbc7b15c9c7280098a07f35 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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 compatibility 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" ruby-lapack-1.8.1/dev/defs/dstein000077500000000000000000000113571325016550400166560ustar00rootroot00000000000000--- :name: dstein :md5sum: 632e25e87ef78ec30feecb369f890ec1 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: doublereal :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstemr000077500000000000000000000275441325016550400166730ustar00rootroot00000000000000--- :name: dstemr :md5sum: 3d5dcbe36e1791efd5d5a833db168b23 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsteqr000077500000000000000000000072531325016550400166720ustar00rootroot00000000000000--- :name: dsteqr :md5sum: 88d76a7dbffcf1191cc46800ecf8affa :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsterf000077500000000000000000000031601325016550400166500ustar00rootroot00000000000000--- :name: dsterf :md5sum: 5dc7d5e9f4d5a3a72037d3b60fce2589 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstev000077500000000000000000000053031325016550400165070ustar00rootroot00000000000000--- :name: dstev :md5sum: 2f4d636a27f6e1a3441dbd47afa973cb :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&jobz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstevd000077500000000000000000000117561325016550400166640ustar00rootroot00000000000000--- :name: dstevd :md5sum: ef38913916fd211c452fc4ca318213ff :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstevr000077500000000000000000000250361325016550400166760ustar00rootroot00000000000000--- :name: dstevr :md5sum: aebc7a9722c572e03966c68225a5a366 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - MAX(1,n-1) - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 20*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dstevx000077500000000000000000000153641325016550400167070ustar00rootroot00000000000000--- :name: dstevx :md5sum: a357b747e988829ca9418642c972bee9 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - MAX(1,n-1) - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsycon000077500000000000000000000055061325016550400166660ustar00rootroot00000000000000--- :name: dsycon :md5sum: f24dbdb6547b437650c544720f6da760 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyconv000077500000000000000000000051351325016550400170520ustar00rootroot00000000000000--- :name: dsyconv :md5sum: 7d1a9b6de72c915da71b7d057f380fea :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyequb000077500000000000000000000065461325016550400170500ustar00rootroot00000000000000--- :name: dsyequb :md5sum: e64c1e10d53f2652cb55a29099f76c13 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyev000077500000000000000000000066341325016550400165240ustar00rootroot00000000000000--- :name: dsyev :md5sum: b35bf3f73e7855142219b77369a0d2cf :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyevd000077500000000000000000000136461325016550400166710ustar00rootroot00000000000000--- :name: dsyevd :md5sum: 0e5b6476a6643a932f9ebab12ff70ff0 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyevr000077500000000000000000000301641325016550400167010ustar00rootroot00000000000000--- :name: dsyevr :md5sum: 545806622e844f3721dd5f6c9dbaf0e1 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 26*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyevx000077500000000000000000000174721325016550400167160ustar00rootroot00000000000000--- :name: dsyevx :md5sum: 4b8e4075425f065e1c4088fde2b251f8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 8*n" - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsygs2000077500000000000000000000057671325016550400166130ustar00rootroot00000000000000--- :name: dsygs2 :md5sum: 756f9e1ce51d4b84e9ec4983cfd676a3 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsygst000077500000000000000000000057641325016550400167120ustar00rootroot00000000000000--- :name: dsygst :md5sum: b617f42ffff403e3bb78dce99c6de8cf :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsygv000077500000000000000000000124351325016550400165220ustar00rootroot00000000000000--- :name: dsygv :md5sum: 1004f5151de1d6f47d819bbd8507eeaa :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsygvd000077500000000000000000000172651325016550400166740ustar00rootroot00000000000000--- :name: dsygvd :md5sum: 85e30d3588fe89d67bd116688747e0d2 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsygvx000077500000000000000000000233031325016550400167060ustar00rootroot00000000000000--- :name: dsygvx :md5sum: d1049907494bb459407d81971dc3b773 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyrfs000077500000000000000000000123161325016550400166760ustar00rootroot00000000000000--- :name: dsyrfs :md5sum: 85f1c6f5556ee003f037a35fc4ac4b07 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsyrfsx000077500000000000000000000376151325016550400170770ustar00rootroot00000000000000--- :name: dsyrfsx :md5sum: 8aa531ba3e04ed4610af5a9318014bae :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsysv000077500000000000000000000130021325016550400165250ustar00rootroot00000000000000--- :name: dsysv :md5sum: ad88b5f290f6f6d3c3471e0ea1db7839 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsysvx000077500000000000000000000235631325016550400167320ustar00rootroot00000000000000--- :name: dsysvx :md5sum: 6486f4357d9e46f47f6b6fad0f47fd94 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsysvxx000077500000000000000000000515611325016550400171210ustar00rootroot00000000000000--- :name: dsysvxx :md5sum: 273b48af0574d8f9d7fb1975f97dcdc9 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/dsyswapr000077500000000000000000000043541325016550400172430ustar00rootroot00000000000000--- :name: dsyswapr :md5sum: b4071132998e7f7d907b231f31a0e28b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytd2000077500000000000000000000116351325016550400166000ustar00rootroot00000000000000--- :name: dsytd2 :md5sum: a634adbb262ee2d31d6afea919b42fed :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytf2000077500000000000000000000132401325016550400165740ustar00rootroot00000000000000--- :name: dsytf2 :md5sum: 01fde80942744339ad514c859f1e3b76 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytrd000077500000000000000000000131741325016550400167000ustar00rootroot00000000000000--- :name: dsytrd :md5sum: 0d42d32d704b2719a5b5bbbe89b1d402 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytrf000077500000000000000000000145121325016550400166770ustar00rootroot00000000000000--- :name: dsytrf :md5sum: 6d21131ea8f86296671b9092b6e08f5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytri000077500000000000000000000051021325016550400166750ustar00rootroot00000000000000--- :name: dsytri :md5sum: 4da55048240e1b7185e9debffbf1a7e7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytri2000077500000000000000000000073701325016550400167700ustar00rootroot00000000000000--- :name: dsytri2 :md5sum: 55abdf3e0f382d7920cd2955e9f19249 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" nb: ilaenv_(&c__1, "DSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytri2x000077500000000000000000000053231325016550400171540ustar00rootroot00000000000000--- :name: dsytri2x :md5sum: 683ca7b4f920246786909d9f75b2ce4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytrs000077500000000000000000000050131325016550400167100ustar00rootroot00000000000000--- :name: dsytrs :md5sum: ca8b35bd83b856d5e15745acb423ab11 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dsytrs2000077500000000000000000000052571325016550400170040ustar00rootroot00000000000000--- :name: dsytrs2 :md5sum: 4d56588bffecdffff2457883247d9b42 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtbcon000077500000000000000000000063311325016550400166350ustar00rootroot00000000000000--- :name: dtbcon :md5sum: b93a38a966efb195be781a50ffe5a3ce :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtbrfs000077500000000000000000000120171325016550400166460ustar00rootroot00000000000000--- :name: dtbrfs :md5sum: 2d7dad49f21789544cccf53137cb26b4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtbtrs000077500000000000000000000066771325016550400167030ustar00rootroot00000000000000--- :name: dtbtrs :md5sum: c3eff624478a9d6e74b0f64935c8c5f3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtfsm000077500000000000000000000211411325016550400164750ustar00rootroot00000000000000--- :name: dtfsm :md5sum: c05922958954dd29b8a6792ef3790102 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - nt - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtftri000077500000000000000000000140521325016550400166570ustar00rootroot00000000000000--- :name: dtftri :md5sum: 0a233694c5876684d380213ab04de7a1 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtfttp000077500000000000000000000124731325016550400166750ustar00rootroot00000000000000--- :name: dtfttp :md5sum: 5a4746cb4cd86d64545e91aae7dfdcc8 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublereal :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: doublereal :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtfttr000077500000000000000000000143441325016550400166760ustar00rootroot00000000000000--- :name: dtfttr :md5sum: ef350058598d512b67124e7c2dde9291 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublereal :intent: input :dims: - ldarf - a: :type: doublereal :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(8*ldarf+1.0f)-1)/2 lda: MAX(1,n) :extras: ldarf: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgevc000077500000000000000000000237071325016550400166460ustar00rootroot00000000000000--- :name: dtgevc :md5sum: 05c0ef877f01207c516547bdc1379d50 :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: doublereal :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: doublereal :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - 6*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgex2000077500000000000000000000142611325016550400165620ustar00rootroot00000000000000--- :name: dtgex2 :md5sum: 3c9cc9551cb92a0e096ca7810e33e06d :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(n*(n2+n1), (n2+n1)*(n2+n1)*2) - info: :type: integer :intent: output :substitutions: lwork: MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2))) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgexc000077500000000000000000000145031325016550400166420ustar00rootroot00000000000000--- :name: dtgexc :md5sum: c2b019b8915f3720467ce4261b0c9e0f :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 4*n+16" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgsen000077500000000000000000000420071325016550400166500ustar00rootroot00000000000000--- :name: dtgsen :md5sum: b42523cce95d8dd0d43f3e1b716e3eab :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: doublereal :intent: output - pr: :type: doublereal :intent: output - dif: :type: doublereal :intent: output :dims: - "2" - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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: - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgsja000077500000000000000000000261161325016550400166430ustar00rootroot00000000000000--- :name: dtgsja :md5sum: bdebfefc02addc07abc6c7dc534b59bb :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublereal :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgsna000077500000000000000000000330171325016550400166450ustar00rootroot00000000000000--- :name: dtgsna :md5sum: 75f02e486f5cd5b703e5e189eb4780e2 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublereal :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - dif: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n + 6" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgsy2000077500000000000000000000210601325016550400165740ustar00rootroot00000000000000--- :name: dtgsy2 :md5sum: aac9343f26eb26fda333d93013fb1815 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublereal :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublereal :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - iwork: :type: integer :intent: workspace :dims: - m+n+2 - pq: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtgsyl000077500000000000000000000230131325016550400166660ustar00rootroot00000000000000--- :name: dtgsyl :md5sum: 331c0eca19ec1c602ac38fd718147715 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublereal :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublereal :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - dif: :type: doublereal :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+6 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtpcon000077500000000000000000000055351325016550400166600ustar00rootroot00000000000000--- :name: dtpcon :md5sum: 958d9db19db171876d7345b6cb787b8a :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtprfs000077500000000000000000000111771325016550400166720ustar00rootroot00000000000000--- :name: dtprfs :md5sum: 6ebdcf9618f401dd3cc557634f2c0b07 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtptri000077500000000000000000000052171325016550400166740ustar00rootroot00000000000000--- :name: dtptri :md5sum: 9fb8837fb48bdcfef3a54e4bdbd604f7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtptrs000077500000000000000000000057251325016550400167120ustar00rootroot00000000000000--- :name: dtptrs :md5sum: cbcbfa93edce4661de4773786622527f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtpttf000077500000000000000000000125241325016550400166720ustar00rootroot00000000000000--- :name: dtpttf :md5sum: 2f271fd495fd7e413550d296b4710f6e :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: doublereal :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtpttr000077500000000000000000000044601325016550400167060ustar00rootroot00000000000000--- :name: dtpttr :md5sum: 2013b72664e417c2618b1d7b80ef088a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - a: :type: doublereal :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrcon000077500000000000000000000061461325016550400166610ustar00rootroot00000000000000--- :name: dtrcon :md5sum: c9e8e550a9265f1dcf6aa23ea7ae653d :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrevc000077500000000000000000000161441325016550400166560ustar00rootroot00000000000000--- :name: dtrevc :md5sum: 22547133be70d0f3940685a9333f6dcb :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublereal :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrexc000077500000000000000000000074721325016550400166640ustar00rootroot00000000000000--- :name: dtrexc :md5sum: f570fee5c461d3f34b24fa3141a74cb3 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrrfs000077500000000000000000000116341325016550400166720ustar00rootroot00000000000000--- :name: dtrrfs :md5sum: b2012a0affdec5f87254e2ff9d8acb59 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrsen000077500000000000000000000257001325016550400166640ustar00rootroot00000000000000--- :name: dtrsen :md5sum: b5686e8b4c84da226a5a36225bfe7ba6 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: doublereal :intent: output - sep: :type: doublereal :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrsna000077500000000000000000000210041325016550400166510ustar00rootroot00000000000000--- :name: dtrsna :md5sum: 71c51825fc44a5eab65748b5f7d3cd1f :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublereal :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - sep: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : 2*(n-1)" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrsyl000077500000000000000000000100561325016550400167040ustar00rootroot00000000000000--- :name: dtrsyl :md5sum: f236af47dea9bd90ec38f415953dc0a5 :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrti2000077500000000000000000000045551325016550400166020ustar00rootroot00000000000000--- :name: dtrti2 :md5sum: 79f9cf1a3356f3c9b6db28e00f2a9527 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrtri000077500000000000000000000046001325016550400166710ustar00rootroot00000000000000--- :name: dtrtri :md5sum: 8441a50f1dc21d4959daa59006cdb017 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrtrs000077500000000000000000000065211325016550400167070ustar00rootroot00000000000000--- :name: dtrtrs :md5sum: 2755db9e25d81bba84931df1c7581f32 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrttf000077500000000000000000000140571325016550400166770ustar00rootroot00000000000000--- :name: dtrttf :md5sum: 02cd214c0c27547c9ac214b4519cadba :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: doublereal :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtrttp000077500000000000000000000043761325016550400167140ustar00rootroot00000000000000--- :name: dtrttp :md5sum: e1a6dcbcddf23f887480015b02d38eb7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: doublereal :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtzrqf000077500000000000000000000064421325016550400167010ustar00rootroot00000000000000--- :name: dtzrqf :md5sum: 0f69e484f62485cb2f20960d94d2dd64 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dtzrzf000077500000000000000000000102351325016550400167050ustar00rootroot00000000000000--- :name: dtzrzf :md5sum: 2407e3cc3aa3ddd54e3c67c69e211f95 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - m - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/dzsum1000077500000000000000000000025241325016550400166070ustar00rootroot00000000000000--- :name: dzsum1 :md5sum: 4c611d4aef843b07b606ed1beec14057 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/icmax1000077500000000000000000000030641325016550400165460ustar00rootroot00000000000000--- :name: icmax1 :md5sum: 6796e7d2b5b097cd869358883d90e06c :category: :function :type: integer :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ieeeck000077500000000000000000000030241325016550400166050ustar00rootroot00000000000000--- :name: ieeeck :md5sum: 912297d3164c5b304dfe88d1002d97b1 :category: :function :type: integer :arguments: - ispec: :type: integer :intent: input - zero: :type: real :intent: input - one: :type: real :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaclc000077500000000000000000000020101325016550400166010ustar00rootroot00000000000000--- :name: ilaclc :md5sum: 40eb72bf94adf85b58d07bf4f02e8461 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaclr000077500000000000000000000020161325016550400166260ustar00rootroot00000000000000--- :name: ilaclr :md5sum: 33fda7f2ac92c6aa5768747a408df60f :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/iladiag000077500000000000000000000016421325016550400167560ustar00rootroot00000000000000--- :name: iladiag :md5sum: dc4a24ef58c1ee18a364cb9ea175b8b2 :category: :function :type: integer :arguments: - diag: :type: char :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/iladlc000077500000000000000000000020241325016550400166070ustar00rootroot00000000000000--- :name: iladlc :md5sum: 519b6e504e227d778f36d69c1080c7ed :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/iladlr000077500000000000000000000020211325016550400166230ustar00rootroot00000000000000--- :name: iladlr :md5sum: 4168f3d5a975c714ef6b4c66396a9f94 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaenv000077500000000000000000000131771325016550400166500ustar00rootroot00000000000000--- :name: ilaenv :md5sum: a17ab3474e363bc9e09f7a174f8d4758 :category: :function :type: integer :arguments: - ispec: :type: integer :intent: input - name: :type: char :intent: input :dims: - "*" - opts: :type: char :intent: input :dims: - "*" - n1: :type: integer :intent: input - n2: :type: integer :intent: input - n3: :type: integer :intent: input - n4: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaprec000077500000000000000000000017771325016550400170140ustar00rootroot00000000000000--- :name: ilaprec :md5sum: ccbd47bb68340bc498273489d1d91536 :category: :function :type: integer :arguments: - prec: :type: char :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaslc000077500000000000000000000020021325016550400166220ustar00rootroot00000000000000--- :name: ilaslc :md5sum: 98329b8613d7cf648a79d80e5f7526ba :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaslr000077500000000000000000000017771325016550400166630ustar00rootroot00000000000000--- :name: ilaslr :md5sum: 20012d009aecf6412a055e523aafddd2 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilatrans000077500000000000000000000017561325016550400172070ustar00rootroot00000000000000--- :name: ilatrans :md5sum: acab13cd31e9e8595e98f380ecc03932 :category: :function :type: integer :arguments: - trans: :type: char :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilauplo000077500000000000000000000016451325016550400170340ustar00rootroot00000000000000--- :name: ilauplo :md5sum: 5876dad692d4c40d99a08273d8c014f9 :category: :function :type: integer :arguments: - uplo: :type: char :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilaver000077500000000000000000000022341325016550400166440ustar00rootroot00000000000000--- :name: ilaver :md5sum: ae154117d9ef11e8dc514356ed2ec2ad :category: :subroutine :arguments: - vers_major: :type: integer :intent: output - vers_minor: :type: integer :intent: output - vers_patch: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilazlc000077500000000000000000000020211325016550400166320ustar00rootroot00000000000000--- :name: ilazlc :md5sum: 62fe4cba939ea297087c8d208791a31b :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ilazlr000077500000000000000000000020161325016550400166550ustar00rootroot00000000000000--- :name: ilazlr :md5sum: e07f8aa44b48e26c9c8627cb2c3fadd1 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/iparmq000077500000000000000000000176041325016550400166620ustar00rootroot00000000000000--- :name: iparmq :md5sum: 73ec37559601ded71e0b8df251efd10e :category: :function :type: integer :arguments: - ispec: :type: integer :intent: input - name: :type: char :intent: input - opts: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lwork: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/izmax1000077500000000000000000000030751325016550400165770ustar00rootroot00000000000000--- :name: izmax1 :md5sum: 9594df1850d6464cd15f4e4b7161a5fa :category: :function :type: integer :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/lsamen000077500000000000000000000027011325016550400166400ustar00rootroot00000000000000--- :name: lsamen :md5sum: 436b27be921ef85dfbabbd827f65a5f1 :category: :function :type: logical :arguments: - n: :type: integer :intent: input - ca: :type: char :intent: input :dims: - "*" - cb: :type: char :intent: input :dims: - "*" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sbbcsd000077500000000000000000000221221325016550400166200ustar00rootroot00000000000000--- :name: sbbcsd :md5sum: 654e0ef0681abf89337a04f3b1aad66f :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: real :intent: input/output :dims: - q - phi: :type: real :intent: input :dims: - q-1 - u1: :type: real :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: real :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: real :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: real :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: real :intent: output :dims: - q - b11e: :type: real :intent: output :dims: - q-1 - b12d: :type: real :intent: output :dims: - q - b12e: :type: real :intent: output :dims: - q-1 - b21d: :type: real :intent: output :dims: - q - b21e: :type: real :intent: output :dims: - q-1 - b22d: :type: real :intent: output :dims: - q - b22e: :type: real :intent: output :dims: - q-1 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sbdsdc000077500000000000000000000164741325016550400166370ustar00rootroot00000000000000--- :name: sbdsdc :md5sum: 363562a2bf0038c64910ac814e09f1c7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - compq: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - u: :type: real :intent: output :dims: - "lsame_(&compq,\"I\") ? ldu : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - "lsame_(&compq,\"I\") ? ldvt : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldvt: :type: integer :intent: input - q: :type: real :intent: output :dims: - "lsame_(&compq,\"I\") ? ldq : 0" - iq: :type: integer :intent: output :dims: - "lsame_(&compq,\"I\") ? ldiq : 0" - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - iwork: :type: integer :intent: workspace :dims: - 8*n - info: :type: integer :intent: output :substitutions: c__9: "9" c__0: "0" ldq: "lsame_(&compq,\"P\") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 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" ldu: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" smlsiz: ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sbdsqr000077500000000000000000000164571325016550400166740ustar00rootroot00000000000000--- :name: sbdsqr :md5sum: 04608bac2e04ed2c5bbedb16150507ac :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - vt: :type: real :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/scsum1000077500000000000000000000025051325016550400165760ustar00rootroot00000000000000--- :name: scsum1 :md5sum: 9056190314a2a56645696ef9574ef9d4 :category: :function :type: real :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sdisna000077500000000000000000000056661325016550400166570ustar00rootroot00000000000000--- :name: sdisna :md5sum: eacdd5bc759975817056bcf26a816e55 :category: :subroutine :arguments: - job: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - sep: :type: real :intent: output :dims: - "lsame_(&job,\"E\") ? m : ((lsame_(&job,\"L\")) || (lsame_(&job,\"R\"))) ? MIN(m,n) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbbrd000077500000000000000000000113361325016550400166300ustar00rootroot00000000000000--- :name: sgbbrd :md5sum: a63bfd9042ac59ad25fe20ca4dea72f6 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - q: :type: real :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: real :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 2*MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbcon000077500000000000000000000064261325016550400166440ustar00rootroot00000000000000--- :name: sgbcon :md5sum: eaa07e1508e7cce0f3ead5f9b4aec35a :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbequ000077500000000000000000000073721325016550400166600ustar00rootroot00000000000000--- :name: sgbequ :md5sum: e05049ad6bde32cc4308286b8c0a3d8e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - MAX(1,m) - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbequb000077500000000000000000000102541325016550400170130ustar00rootroot00000000000000--- :name: sgbequb :md5sum: eebb96e018d76111b5c0fb465d6e56d3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbrfs000077500000000000000000000126171325016550400166560ustar00rootroot00000000000000--- :name: sgbrfs :md5sum: 5c391cc7af00cb69142b04cd8dda8a1d :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbrfsx000077500000000000000000000424151325016550400170450ustar00rootroot00000000000000--- :name: sgbrfsx :md5sum: 6b886aa6b32d084299e4e5d743981a5b :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbsv000077500000000000000000000114421325016550400165070ustar00rootroot00000000000000--- :name: sgbsv :md5sum: 6196dc1254d6b974ab34de77816b9fe2 :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbsvx000077500000000000000000000344101325016550400166770ustar00rootroot00000000000000--- :name: sgbsvx :md5sum: 624316c11a224f632a298e7839e4c07a :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: output :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/sgbsvxx000077500000000000000000000563641325016550400171030ustar00rootroot00000000000000--- :name: sgbsvxx :md5sum: 1a073673d020ab52ceac35b96fd91246 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/sgbtf2000077500000000000000000000074151325016550400165570ustar00rootroot00000000000000--- :name: sgbtf2 :md5sum: 994c6c0f6c9f543f6e7b3330c848aeb8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbtrf000077500000000000000000000074021325016550400166530ustar00rootroot00000000000000--- :name: sgbtrf :md5sum: 8af1a2a140a4794550498ad4693a88c2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgbtrs000077500000000000000000000057621325016550400166770ustar00rootroot00000000000000--- :name: sgbtrs :md5sum: 67897804c7f0b5c5cc0d53f7458b2608 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgebak000077500000000000000000000054331325016550400166220ustar00rootroot00000000000000--- :name: sgebak :md5sum: b8fe3fccd7f265282dc765e8f8bfb770 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgebal000077500000000000000000000103701325016550400166170ustar00rootroot00000000000000--- :name: sgebal :md5sum: f24299883b8992810cf76ee8abf27538 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgebd2000077500000000000000000000131421325016550400165300ustar00rootroot00000000000000--- :name: sgebd2 :md5sum: e4e4458e28f45673d7327d16a19ea99c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: real :intent: output :dims: - MIN(m,n) - taup: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgebrd000077500000000000000000000144411325016550400166330ustar00rootroot00000000000000--- :name: sgebrd :md5sum: e97ad4e90b71b7f4c64185e3257c2608 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: real :intent: output :dims: - MIN(m,n) - taup: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgecon000077500000000000000000000047251325016550400166470ustar00rootroot00000000000000--- :name: sgecon :md5sum: 946a6d0eb733c9d751e18bcd9e264365 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeequ000077500000000000000000000064201325016550400166540ustar00rootroot00000000000000--- :name: sgeequ :md5sum: 5b2618a0032479b4096d2866a08609c9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeequb000077500000000000000000000072501325016550400170200ustar00rootroot00000000000000--- :name: sgeequb :md5sum: 4d9d6bdf1c8036333710b2bc98ec4216 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgees000077500000000000000000000156331325016550400164770ustar00rootroot00000000000000--- :name: sgees :md5sum: a4548129118af3f395da9ff74b9e634a :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: real - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vs: :type: real :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeesx000077500000000000000000000235471325016550400166720ustar00rootroot00000000000000--- :name: sgeesx :md5sum: 64fcd2b5803aefdf7af907e57f81fd53 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: real - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vs: :type: real :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: real :intent: output - rcondv: :type: real :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeev000077500000000000000000000130521325016550400164730ustar00rootroot00000000000000--- :name: sgeev :md5sum: 65ee2e476fb8f76d13c30265f57d9bc0 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 4*n : 3*n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeevx000077500000000000000000000250011325016550400166600ustar00rootroot00000000000000--- :name: sgeevx :md5sum: def8c51083d6025e43422c29fe495dfd :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 0 : 2*n-2" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgegs000077500000000000000000000162621325016550400165000ustar00rootroot00000000000000--- :name: sgegs :md5sum: c623dc99f7ba59741a8e3ad0a7221b09 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vsl: :type: real :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: real :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 4*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgegv000077500000000000000000000255051325016550400165030ustar00rootroot00000000000000--- :name: sgegv :md5sum: f9d4bda2151f7908cecf6379e361761b :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgehd2000077500000000000000000000073361325016550400165460ustar00rootroot00000000000000--- :name: sgehd2 :md5sum: 63d6daed935852377ebae7aa7ad348d6 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgehrd000077500000000000000000000112631325016550400166400ustar00rootroot00000000000000--- :name: sgehrd :md5sum: fc9043ef5024995f553bea9fd9795fcd :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgejsv000077500000000000000000002200571325016550400166700ustar00rootroot00000000000000--- :name: sgejsv :md5sum: 014d15d64a56599ae987928ca94d6d5e :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobr: :type: char :intent: input - jobt: :type: char :intent: input - jobp: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: real :intent: output :dims: - n - u: :type: real :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - v: :type: real :intent: output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: real :intent: input/output :dims: - lwork - 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 :dims: - m+3*n - info: :type: integer :intent: output :substitutions: ldu: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? m : 1" ldv: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? n : 1" :fortran_help: " 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@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" ruby-lapack-1.8.1/dev/defs/sgelq2000077500000000000000000000047151325016550400165650ustar00rootroot00000000000000--- :name: sgelq2 :md5sum: 1e79428ba3255ee6646e52547c2b32cf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgelqf000077500000000000000000000071651325016550400166530ustar00rootroot00000000000000--- :name: sgelqf :md5sum: 167e1d10b4e9f338482f58398f79a993 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgels000077500000000000000000000132141325016550400164770ustar00rootroot00000000000000--- :name: sgels :md5sum: 994913d24d2a9adf9a93e5dbac66f485 :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/sgelsd000077500000000000000000000160241325016550400166450ustar00rootroot00000000000000--- :name: sgelsd :md5sum: d79751f910a02ca7f84d323a4de8dfe0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - info: :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)) nlvl: MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1)) smlsiz: ilaenv_(&c__9,"SGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " 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 transformations 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" ruby-lapack-1.8.1/dev/defs/sgelss000077500000000000000000000114341325016550400166640ustar00rootroot00000000000000--- :name: sgelss :md5sum: 6214c742930da2ac2e5dea89d942672f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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: 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\ *\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" ruby-lapack-1.8.1/dev/defs/sgelsx000077500000000000000000000117471325016550400167000ustar00rootroot00000000000000--- :name: sgelsx :md5sum: e4e07c42aeca28db21674ddeedfea311 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgelsy000077500000000000000000000143671325016550400167020ustar00rootroot00000000000000--- :name: sgelsy :md5sum: ef95fb1aa71e1dc5559fe35dd26c6aac :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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: 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\ *\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" ruby-lapack-1.8.1/dev/defs/sgeql2000077500000000000000000000051001325016550400165520ustar00rootroot00000000000000--- :name: sgeql2 :md5sum: d3fdd8a2b8cb93ae73236c79e8143f4e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqlf000077500000000000000000000074161325016550400166520ustar00rootroot00000000000000--- :name: sgeqlf :md5sum: 22cbd1cd4a3f380748b6ebbd31b6179e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqp3000077500000000000000000000073371325016550400165750ustar00rootroot00000000000000--- :name: sgeqp3 :md5sum: d403640a3535834978e177dfacbf62cd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n+1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqpf000077500000000000000000000063701325016550400166540ustar00rootroot00000000000000--- :name: sgeqpf :md5sum: d0a540162c9e235819915865a59db357 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqr2000077500000000000000000000047061325016550400165730ustar00rootroot00000000000000--- :name: sgeqr2 :md5sum: 06513c36c991798679679c5ae0ee68ee :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqr2p000077500000000000000000000047111325016550400167470ustar00rootroot00000000000000--- :name: sgeqr2p :md5sum: 5248af5ed9acffff08cb0b94440311ff :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqrf000077500000000000000000000072161325016550400166560ustar00rootroot00000000000000--- :name: sgeqrf :md5sum: a14be5141cf6a70a428306a636c55c81 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgeqrfp000077500000000000000000000072221325016550400170330ustar00rootroot00000000000000--- :name: sgeqrfp :md5sum: cca781b3e9a0170ae3da210612086ca7 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgerfs000077500000000000000000000111221325016550400166470ustar00rootroot00000000000000--- :name: sgerfs :md5sum: bee46a94b59af9bfbc6a4ed911c55af1 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgerfsx000077500000000000000000000377671325016550400170660ustar00rootroot00000000000000--- :name: sgerfsx :md5sum: 876fcf4bac7f0e0eb90f1afa6af67a87 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgerq2000077500000000000000000000051051325016550400165650ustar00rootroot00000000000000--- :name: sgerq2 :md5sum: 8307cc39ced248fef7772c32448921a0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgerqf000077500000000000000000000074261325016550400166610ustar00rootroot00000000000000--- :name: sgerqf :md5sum: fd8676bd3914a45a158ab6460ae027b0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgesc2000077500000000000000000000044661325016550400165610ustar00rootroot00000000000000--- :name: sgesc2 :md5sum: a1d942fb0e32d88b83645ceab007aaaa :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: real :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgesdd000077500000000000000000000170051325016550400166350ustar00rootroot00000000000000--- :name: sgesdd :md5sum: 4cf2bd2eb74c4dd85a572b817ec81b1a :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: real :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 8*MIN(m,n) - info: :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\") || 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\ *\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" ruby-lapack-1.8.1/dev/defs/sgesv000077500000000000000000000060401325016550400165100ustar00rootroot00000000000000--- :name: sgesv :md5sum: 2f2e91d8b360280d7c090a0bdf896bf9 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgesvd000077500000000000000000000157261325016550400166670ustar00rootroot00000000000000--- :name: sgesvd :md5sum: d1b4d1842f793e4c465046572749c3b6 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: real :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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\ * 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" ruby-lapack-1.8.1/dev/defs/sgesvj000077500000000000000000000365701325016550400166750ustar00rootroot00000000000000--- :name: sgesvj :md5sum: 6fcf21eb9eda45c9d276fe7d46e1a972 :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: real :intent: output :dims: - n - mv: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: real :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(6,m+n) - info: :type: integer :intent: output :substitutions: lwork: MAX(6,m+n) :fortran_help: " 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@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" ruby-lapack-1.8.1/dev/defs/sgesvx000077500000000000000000000323131325016550400167020ustar00rootroot00000000000000--- :name: sgesvx :md5sum: 60e2461f042fe2e20d703a515b1117e4 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: output :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/sgesvxx000077500000000000000000000547501325016550400171030ustar00rootroot00000000000000--- :name: sgesvxx :md5sum: f1d72a70abcead56ab0ad3c271a07a62 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/sgetc2000077500000000000000000000050051325016550400165500ustar00rootroot00000000000000--- :name: sgetc2 :md5sum: 8ba0f6ea4d1dc51b6b0e3d59cbf825d9 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgetf2000077500000000000000000000045171325016550400165620ustar00rootroot00000000000000--- :name: sgetf2 :md5sum: 6afacce566d20b4c1f8a8014c205bd97 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgetrf000077500000000000000000000045251325016550400166610ustar00rootroot00000000000000--- :name: sgetrf :md5sum: fd03c253a8862b16c1b50e2ad7d0db20 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgetri000077500000000000000000000051741325016550400166650ustar00rootroot00000000000000--- :name: sgetri :md5sum: 503b233c194f05b3d4f490711646e246 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgetrs000077500000000000000000000047001325016550400166710ustar00rootroot00000000000000--- :name: sgetrs :md5sum: 6bb0828613c13abf696da0b96b456275 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggbak000077500000000000000000000073511325016550400166250ustar00rootroot00000000000000--- :name: sggbak :md5sum: 578f59f90aa7528cd8b5d765afa93309 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: real :intent: input :dims: - n - rscale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggbal000077500000000000000000000117011325016550400166200ustar00rootroot00000000000000--- :name: sggbal :md5sum: 90918ecfe5b5c156b054f0f9447942ae :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgges000077500000000000000000000231461325016550400164770ustar00rootroot00000000000000--- :name: sgges :md5sum: c82764a1dfe0f3e66ab308ca3336562a :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: real - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vsl: :type: real :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: real :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(8*n,6*n+16) - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggesx000077500000000000000000000316271325016550400166720ustar00rootroot00000000000000--- :name: sggesx :md5sum: 3515fd1426593154ec1fad4573f2ba9c :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: real - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vsl: :type: real :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: real :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: real :intent: output :dims: - "2" - rcondv: :type: real :intent: output :dims: - "2" - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggev000077500000000000000000000161451325016550400165030ustar00rootroot00000000000000--- :name: sggev :md5sum: c8f02404add51e664f048466e576c7d2 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,8*n) - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggevx000077500000000000000000000340061325016550400166670ustar00rootroot00000000000000--- :name: sggevx :md5sum: 7044c66a49c1acd580038604dab023c1 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - bbnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - "lsame_(&sense,\"E\") ? 0 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggglm000077500000000000000000000122121325016550400166370ustar00rootroot00000000000000--- :name: sggglm :md5sum: aba2d257bbf8b9411b9165fa82316214 :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - x: :type: real :intent: output :dims: - m - y: :type: real :intent: output :dims: - p - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgghrd000077500000000000000000000135031325016550400166410ustar00rootroot00000000000000--- :name: sgghrd :md5sum: d0503df67d201eb3464bb900dd79f061 :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgglse000077500000000000000000000120441325016550400166460ustar00rootroot00000000000000--- :name: sgglse :md5sum: f499922c0d1a1977b7b6beb425364495 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - m - d: :type: real :intent: input/output :dims: - p - x: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggqrf000077500000000000000000000155111325016550400166550ustar00rootroot00000000000000--- :name: sggqrf :md5sum: f1e600b5a35285017faea41a9d40ae77 :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: real :intent: output :dims: - MIN(n,m) - b: :type: real :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: real :intent: output :dims: - MIN(n,p) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggrqf000077500000000000000000000154531325016550400166620ustar00rootroot00000000000000--- :name: sggrqf :md5sum: c7c0fb9d6a37dbbeb48942c85c40711e :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: real :intent: output :dims: - MIN(m,n) - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: real :intent: output :dims: - MIN(p,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sggsvd000077500000000000000000000241641325016550400166650ustar00rootroot00000000000000--- :name: sggsvd :md5sum: d33cddf77cac04b083208610d7b84d71 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: real :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: real :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(3*n,m - p)+n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: 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" :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\ * 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" ruby-lapack-1.8.1/dev/defs/sggsvp000077500000000000000000000151251325016550400166760ustar00rootroot00000000000000--- :name: sggsvp :md5sum: 8f9fa51bd57835c14e5543a88bb2b821 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: real :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: real :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - tau: :type: real :intent: workspace :dims: - n - work: :type: real :intent: workspace :dims: - MAX(MAX(3*n,m),p) - info: :type: integer :intent: output :substitutions: 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" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgsvj0000077500000000000000000000166441325016550400166100ustar00rootroot00000000000000--- :name: sgsvj0 :md5sum: 3d2a3ab6cc4e65db034ed891716f6493 :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - sva: :type: real :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: integer :intent: input - sfmin: :type: integer :intent: input - tol: :type: real :intent: input - nsweep: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " 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@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" ruby-lapack-1.8.1/dev/defs/sgsvj1000077500000000000000000000206771325016550400166120ustar00rootroot00000000000000--- :name: sgsvj1 :md5sum: cbe49ab014331204cca976ff4c40a398 :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - sva: :type: real :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: integer :intent: input - sfmin: :type: integer :intent: input - tol: :type: real :intent: input - nsweep: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgtcon000077500000000000000000000065441325016550400166670ustar00rootroot00000000000000--- :name: sgtcon :md5sum: 1e88f60a1e7dead4af7e4f638ef858ac :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgtrfs000077500000000000000000000126211325016550400166730ustar00rootroot00000000000000--- :name: sgtrfs :md5sum: 07d24cfa02e3c548ded77eb4cde10139 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - dlf: :type: real :intent: input :dims: - n-1 - df: :type: real :intent: input :dims: - n - duf: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgtsv000077500000000000000000000056211325016550400165330ustar00rootroot00000000000000--- :name: sgtsv :md5sum: d0c8275ef5b870545d926bfab7aac31d :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input/output :dims: - n-1 - d: :type: real :intent: input/output :dims: - n - du: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgtsvx000077500000000000000000000232071325016550400167230ustar00rootroot00000000000000--- :name: sgtsvx :md5sum: 424970766dd3d41a2404ab38f5143612 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - dlf: :type: real :intent: input/output :dims: - n-1 - df: :type: real :intent: input/output :dims: - n - duf: :type: real :intent: input/output :dims: - n-1 - du2: :type: real :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgttrf000077500000000000000000000060401325016550400166720ustar00rootroot00000000000000--- :name: sgttrf :md5sum: 4e9324d553ecb9fda65af78de9d470e8 :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: real :intent: input/output :dims: - n-1 - d: :type: real :intent: input/output :dims: - n - du: :type: real :intent: input/output :dims: - n-1 - du2: :type: real :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgttrs000077500000000000000000000067061325016550400167200ustar00rootroot00000000000000--- :name: sgttrs :md5sum: 8a9f866de5c6cec7691ae47b40d6cc6c :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sgtts2000077500000000000000000000057001325016550400166110ustar00rootroot00000000000000--- :name: sgtts2 :md5sum: cea36b0cbb0bba04fe5ed67e019b34c7 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/shgeqz000077500000000000000000000250721325016550400166700ustar00rootroot00000000000000--- :name: shgeqz :md5sum: 50f3e0f180cee44115f687d20453be96 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/shsein000077500000000000000000000212401325016550400166510ustar00rootroot00000000000000--- :name: shsein :md5sum: 41d65c46fe2e60e8a05df236c5bd8cfb :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - h: :type: real :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: input/output :dims: - n - wi: :type: real :intent: input :dims: - n - vl: :type: real :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: real :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - (n+2)*n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/shseqr000077500000000000000000000277471325016550400167070ustar00rootroot00000000000000--- :name: shseqr :md5sum: 717af2c10d7849612c9648d71a873ad5 :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - z: :type: real :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sisnan000077500000000000000000000013331325016550400166540ustar00rootroot00000000000000--- :name: sisnan :md5sum: 59f568b95ecad80e459328f43736527e :category: :function :type: logical :arguments: - sin: :type: real :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_gbamv000077500000000000000000000120211325016550400173100ustar00rootroot00000000000000--- :name: sla_gbamv :md5sum: cbd7ec5ee7b6f3a1cb37f6d024c2d320 :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: real :intent: input - ab: :type: real :intent: input :dims: - ldab - ldab: :type: integer :intent: input - x: :type: real :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: lda: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_gbrcond000077500000000000000000000111061325016550400176350ustar00rootroot00000000000000--- :name: sla_gbrcond :md5sum: ff5d11e89ee27a58b83e3bf9843a8a8c :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 5*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_gbrfsx_extended000077500000000000000000000357111325016550400214020ustar00rootroot00000000000000--- :name: sla_gbrfsx_extended :md5sum: 2c7e202e5db9c2ecbab23f7b2f5f177f :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_norms - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_norms - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: 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\ * =======\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" ruby-lapack-1.8.1/dev/defs/sla_gbrpvgrw000077500000000000000000000053751325016550400200720ustar00rootroot00000000000000--- :name: sla_gbrpvgrw :md5sum: 03f8d3a9809ecee2db4307d6345927c2 :category: :function :type: real :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_geamv000077500000000000000000000112651325016550400173240ustar00rootroot00000000000000--- :name: sla_geamv :md5sum: 2e179391d15f035cb8c5119e60dcdd05 :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: real :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)" - incy: :type: integer :intent: input :substitutions: lda: MAX(1, m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_gercond000077500000000000000000000075071325016550400176520ustar00rootroot00000000000000--- :name: sla_gercond :md5sum: e387f0de4f947d692671de72b3925269 :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_gerfsx_extended000077500000000000000000000350511325016550400214020ustar00rootroot00000000000000--- :name: sla_gerfsx_extended :md5sum: e1c13e3630acd1f6b602bcd6c9654aca :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_lin_berr000077500000000000000000000046361325016550400200250ustar00rootroot00000000000000--- :name: sla_lin_berr :md5sum: a5c1dc09d744f377635f2d5129303a43 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: real :intent: input :dims: - n - nrhs - ayb: :type: real :intent: input :dims: - n - nrhs - berr: :type: real :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_porcond000077500000000000000000000067541325016550400177000ustar00rootroot00000000000000--- :name: sla_porcond :md5sum: f0d498acfd1d554092c078a19690e2e6 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_porfsx_extended000077500000000000000000000341251325016550400214260ustar00rootroot00000000000000--- :name: sla_porfsx_extended :md5sum: 48316f84c94865849f375c5fbf379958 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_porpvgrw000077500000000000000000000045231325016550400201120ustar00rootroot00000000000000--- :name: sla_porpvgrw :md5sum: 2edaf717ab5460c71293b964d4229d50 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: real :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_rpvgrw000077500000000000000000000037731325016550400175610ustar00rootroot00000000000000--- :name: sla_rpvgrw :md5sum: ad9440dfdcfca1213188ee2e5876bf80 :category: :function :type: real :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_syamv000077500000000000000000000111401325016550400173540ustar00rootroot00000000000000--- :name: sla_syamv :md5sum: 3fe7d0b46433be548d70a984dd25ac3e :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: real :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: MAX(1, n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_syrcond000077500000000000000000000074631325016550400177130ustar00rootroot00000000000000--- :name: sla_syrcond :md5sum: 5eaaae108449bbac6d01191c8809734f :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_syrfsx_extended000077500000000000000000000345071325016550400214470ustar00rootroot00000000000000--- :name: sla_syrfsx_extended :md5sum: fd7630441b09c3526e2b43719ebdce44 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_syrpvgrw000077500000000000000000000056351325016550400201340ustar00rootroot00000000000000--- :name: sla_syrpvgrw :md5sum: 2520bed9e6244f2db3d5b849f49a59d2 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sla_wwaddw000077500000000000000000000025641325016550400175240ustar00rootroot00000000000000--- :name: sla_wwaddw :md5sum: 7fcd8de2e27cfe0dee3a476f013791a0 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - n - y: :type: real :intent: input/output :dims: - n - w: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slabad000077500000000000000000000031251325016550400166100ustar00rootroot00000000000000--- :name: slabad :md5sum: 7aed9e15f2c5ce86f54581079167d813 :category: :subroutine :arguments: - small: :type: real :intent: input/output - large: :type: real :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slabrd000077500000000000000000000144771325016550400166450ustar00rootroot00000000000000--- :name: slabrd :md5sum: 2b3826069fc3770fe2db03223e112bbc :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MAX(1,nb) - e: :type: real :intent: output :dims: - MAX(1,nb) - tauq: :type: real :intent: output :dims: - MAX(1,nb) - taup: :type: real :intent: output :dims: - MAX(1,nb) - x: :type: real :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: real :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: m ldy: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slacn2000077500000000000000000000056261325016550400165540ustar00rootroot00000000000000--- :name: slacn2 :md5sum: 9887439066195ba0232deeddaf0c56dd :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: real :intent: workspace :dims: - n - x: :type: real :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slacon000077500000000000000000000046621325016550400166500ustar00rootroot00000000000000--- :name: slacon :md5sum: d96882f0cf8bca75abc96f74556cd278 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: real :intent: workspace :dims: - n - x: :type: real :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slacpy000077500000000000000000000042161325016550400166570ustar00rootroot00000000000000--- :name: slacpy :md5sum: fb3c0582ff1682fc252e5d6ad1a2f089 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sladiv000077500000000000000000000025761325016550400166550ustar00rootroot00000000000000--- :name: sladiv :md5sum: ec621296a17da602467a623f15f8653a :category: :subroutine :arguments: - a: :type: real :intent: input - b: :type: real :intent: input - c: :type: real :intent: input - d: :type: real :intent: input - p: :type: real :intent: output - q: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slae2000077500000000000000000000034761325016550400164010ustar00rootroot00000000000000--- :name: slae2 :md5sum: 18f4efd60fb42dab6017abab77961a75 :category: :subroutine :arguments: - a: :type: real :intent: input - b: :type: real :intent: input - c: :type: real :intent: input - rt1: :type: real :intent: output - rt2: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaebz000077500000000000000000000275741325016550400166600ustar00rootroot00000000000000--- :name: slaebz :md5sum: 49712227df054fa19a38f7928b6b8461 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - nitmax: :type: integer :intent: input - n: :type: integer :intent: input - mmax: :type: integer :intent: input - minp: :type: integer :intent: input - nbmin: :type: integer :intent: input - abstol: :type: real :intent: input - reltol: :type: real :intent: input - pivmin: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n - e2: :type: real :intent: input :dims: - n - nval: :type: integer :intent: input/output :dims: - "(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0" - ab: :type: real :intent: input/output :dims: - mmax - "2" - c: :type: real :intent: input/output :dims: - "ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0" - mout: :type: integer :intent: output - nab: :type: integer :intent: input/output :dims: - mmax - "2" - work: :type: real :intent: workspace :dims: - mmax - iwork: :type: integer :intent: workspace :dims: - mmax - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed0000077500000000000000000000122241325016550400165320ustar00rootroot00000000000000--- :name: slaed0 :md5sum: 502ff7fe93854f23945ff52ecee82f3d :category: :subroutine :arguments: - icompq: :type: integer :intent: input - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input :dims: - n-1 - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: real :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0" - iwork: :type: integer :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0" - info: :type: integer :intent: output :substitutions: ldqs: "icompq == 1 ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed1000077500000000000000000000117021325016550400165330ustar00rootroot00000000000000--- :name: slaed1 :md5sum: d07835f50a422bece671635ac839355a :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: real :intent: input - cutpnt: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n + pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/slaed2000077500000000000000000000144551325016550400165440ustar00rootroot00000000000000--- :name: slaed2 :md5sum: e070f3045768b0a9fca4dcd7e04b36cc :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: real :intent: input/output - z: :type: real :intent: input :dims: - n - dlamda: :type: real :intent: output :dims: - n - w: :type: real :intent: output :dims: - n - q2: :type: real :intent: output :dims: - pow(n1,2)+pow(n-n1,2) - indx: :type: integer :intent: workspace :dims: - n - indxc: :type: integer :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed3000077500000000000000000000124561325016550400165440ustar00rootroot00000000000000--- :name: slaed3 :md5sum: 6f3222590ab64b2fd11ec8b308ea8611 :category: :subroutine :arguments: - k: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: real :intent: input - dlamda: :type: real :intent: input/output :dims: - k - q2: :type: real :intent: input :dims: - n - n - indx: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - w: :type: real :intent: input/output :dims: - k - s: :type: real :intent: workspace :dims: - MAX(1,k) - n1 + 1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed4000077500000000000000000000064211325016550400165400ustar00rootroot00000000000000--- :name: slaed4 :md5sum: d6ca8d8edb3a5f41edc126568787c862 :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - z: :type: real :intent: input :dims: - n - delta: :type: real :intent: output :dims: - n - rho: :type: real :intent: input - dlam: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed5000077500000000000000000000037521325016550400165450ustar00rootroot00000000000000--- :name: slaed5 :md5sum: 1e0d84a3982b12261a34f11249234b49 :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - "2" - z: :type: real :intent: input :dims: - "2" - delta: :type: real :intent: output :dims: - "2" - rho: :type: real :intent: input - dlam: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed6000077500000000000000000000060401325016550400165370ustar00rootroot00000000000000--- :name: slaed6 :md5sum: 13a1e6df9b21c8b69ce9525581404001 :category: :subroutine :arguments: - kniter: :type: integer :intent: input - orgati: :type: logical :intent: input - rho: :type: real :intent: input - d: :type: real :intent: input :dims: - "3" - z: :type: real :intent: input :dims: - "3" - finit: :type: real :intent: input - tau: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed7000077500000000000000000000176171325016550400165540ustar00rootroot00000000000000--- :name: slaed7 :md5sum: b12e352cfd0208ab191e0ebd1f68ecd6 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: output :dims: - n - rho: :type: real :intent: input - cutpnt: :type: integer :intent: input - qstore: :type: real :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: real :intent: input :dims: - "2" - n*LG(n) - work: :type: real :intent: workspace :dims: - 3*n+qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/slaed8000077500000000000000000000162171325016550400165500ustar00rootroot00000000000000--- :name: slaed8 :md5sum: 695bf39ffc8e6dd4d22f1ba3685aeddc :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - "icompq==0 ? 0 : ldq" - "icompq==0 ? 0 : n" - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input :dims: - n - rho: :type: real :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: real :intent: input :dims: - n - dlamda: :type: real :intent: output :dims: - n - q2: :type: real :intent: output :dims: - "icompq==0 ? 0 : ldq2" - "icompq==0 ? 0 : n" - ldq2: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: real :intent: output :dims: - "2" - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldq2: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaed9000077500000000000000000000100611325016550400165400ustar00rootroot00000000000000--- :name: slaed9 :md5sum: 19d8d043e908de337edab6e6515b3c83 :category: :subroutine :arguments: - k: :type: integer :intent: input - kstart: :type: integer :intent: input - kstop: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: output :dims: - MAX(1,n) - q: :type: real :intent: workspace :dims: - ldq - MAX(1,n) - ldq: :type: integer :intent: input - rho: :type: real :intent: input - dlamda: :type: real :intent: input :dims: - k - w: :type: real :intent: input :dims: - k - s: :type: real :intent: output :dims: - lds - k - lds: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldq: MAX( 1, n ) lds: MAX( 1, k ) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaeda000077500000000000000000000104051325016550400166120ustar00rootroot00000000000000--- :name: slaeda :md5sum: 24a9751e7a3bb6e15256dfe9218457ca :category: :subroutine :arguments: - n: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: real :intent: input :dims: - "2" - n*LG(n) - q: :type: real :intent: input :dims: - pow(n,2) - qptr: :type: integer :intent: input :dims: - ldqptr - z: :type: real :intent: output :dims: - n - ztemp: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldqptr-2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaein000077500000000000000000000102041325016550400166310ustar00rootroot00000000000000--- :name: slaein :md5sum: db0ea0cba06ef1453f7435398c35d394 :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: real :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: input - wi: :type: real :intent: input - vr: :type: real :intent: input/output :dims: - n - vi: :type: real :intent: input/output :dims: - n - b: :type: real :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - eps3: :type: real :intent: input - smlnum: :type: real :intent: input - bignum: :type: real :intent: input - info: :type: integer :intent: output :substitutions: ldb: n+1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaev2000077500000000000000000000046151325016550400165630ustar00rootroot00000000000000--- :name: slaev2 :md5sum: b2933ce4bc39bd2862647978c0b49408 :category: :subroutine :arguments: - a: :type: real :intent: input - b: :type: real :intent: input - c: :type: real :intent: input - rt1: :type: real :intent: output - rt2: :type: real :intent: output - cs1: :type: real :intent: output - sn1: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaexc000077500000000000000000000060141325016550400166410ustar00rootroot00000000000000--- :name: slaexc :md5sum: 7b147a6610de47105a915414572b084a :category: :subroutine :arguments: - wantq: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slag2000077500000000000000000000110021325016550400163630ustar00rootroot00000000000000--- :name: slag2 :md5sum: 4299c5465453583eb5c3f7ba95c8c2df :category: :subroutine :arguments: - a: :type: real :intent: input :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - safmin: :type: real :intent: input - scale1: :type: real :intent: output - scale2: :type: real :intent: output - wr1: :type: real :intent: output - wr2: :type: real :intent: output - wi: :type: real :intent: output :substitutions: {} :fortran_help: " 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 threshold 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\ * threshold 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" ruby-lapack-1.8.1/dev/defs/slag2d000077500000000000000000000035421325016550400165410ustar00rootroot00000000000000--- :name: slag2d :md5sum: 66ca6fd237c1f18d65be3a3235538d2d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - sa: :type: real :intent: input :dims: - ldsa - n - ldsa: :type: integer :intent: input - a: :type: doublereal :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slags2000077500000000000000000000053761325016550400165670ustar00rootroot00000000000000--- :name: slags2 :md5sum: 33da975bfa8208d409d3b33a3fa68c1d :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: real :intent: input - a2: :type: real :intent: input - a3: :type: real :intent: input - b1: :type: real :intent: input - b2: :type: real :intent: input - b3: :type: real :intent: input - csu: :type: real :intent: output - snu: :type: real :intent: output - csv: :type: real :intent: output - snv: :type: real :intent: output - csq: :type: real :intent: output - snq: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slagtf000077500000000000000000000105641325016550400166470ustar00rootroot00000000000000--- :name: slagtf :md5sum: 122493f77edd75a8cd45086d994ac58d :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n - lambda: :type: real :intent: input - b: :type: real :intent: input/output :dims: - n-1 - c: :type: real :intent: input/output :dims: - n-1 - tol: :type: real :intent: input - d: :type: real :intent: output :dims: - n-2 - in: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slagtm000077500000000000000000000057721325016550400166630ustar00rootroot00000000000000--- :name: slagtm :md5sum: 38a005a5d2de8569634e40e7455b437a :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: real :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: real :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slagts000077500000000000000000000113011325016550400166520ustar00rootroot00000000000000--- :name: slagts :md5sum: 6a4561511123cd1f15a6d9c4867535a3 :category: :subroutine :arguments: - job: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - n-1 - c: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n-2 - in: :type: integer :intent: input :dims: - n - y: :type: real :intent: input/output :dims: - n - tol: :type: real :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slagv2000077500000000000000000000070551325016550400165660ustar00rootroot00000000000000--- :name: slagv2 :md5sum: 00d6ee2cee93c5623638b482ed41daa5 :category: :subroutine :arguments: - a: :type: real :intent: input/output :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - "2" - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - "2" - alphai: :type: real :intent: output :dims: - "2" - beta: :type: real :intent: output :dims: - "2" - csl: :type: real :intent: output - snl: :type: real :intent: output - csr: :type: real :intent: output - snr: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slahqr000077500000000000000000000145231325016550400166600ustar00rootroot00000000000000--- :name: slahqr :md5sum: 5cbfbd1abeed40e4a90c345cdab7c428 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slahr2000077500000000000000000000115201325016550400165530ustar00rootroot00000000000000--- :name: slahr2 :md5sum: 036e30e7208a92f8c4dea174520af37e :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MAX(1,nb) - t: :type: real :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: real :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slahrd000077500000000000000000000105041325016550400166360ustar00rootroot00000000000000--- :name: slahrd :md5sum: 310f3d05f9a370f74c5c3899e0327653 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MAX(1,nb) - t: :type: real :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: real :intent: output :dims: - ldy - MAX(1,nb) - ldy: :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\ * 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" ruby-lapack-1.8.1/dev/defs/slaic1000077500000000000000000000051361325016550400165420ustar00rootroot00000000000000--- :name: slaic1 :md5sum: 5a7ca2ea3cbe409b461402c0b08dd9ba :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: real :intent: input :dims: - j - sest: :type: real :intent: input - w: :type: real :intent: input :dims: - j - gamma: :type: real :intent: input - sestpr: :type: real :intent: output - s: :type: real :intent: output - c: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaln2000077500000000000000000000142151325016550400165570ustar00rootroot00000000000000--- :name: slaln2 :md5sum: 1daa4014ddd7a0cc7ee7dcf6e2b38829 :category: :subroutine :arguments: - ltrans: :type: logical :intent: input - na: :type: integer :intent: input - nw: :type: integer :intent: input - smin: :type: real :intent: input - ca: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - na - lda: :type: integer :intent: input - d1: :type: real :intent: input - d2: :type: real :intent: input - b: :type: real :intent: input :dims: - ldb - nw - ldb: :type: integer :intent: input - wr: :type: real :intent: input - wi: :type: real :intent: input - x: :type: real :intent: output :dims: - ldx - nw - ldx: :type: integer :intent: input - scale: :type: real :intent: output - xnorm: :type: real :intent: output - info: :type: integer :intent: output :substitutions: ldx: na :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slals0000077500000000000000000000165721325016550400165720ustar00rootroot00000000000000--- :name: slals0 :md5sum: 14617d38dd37bd0a84a9ec2cb4910f09 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: real :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: real :intent: input :dims: - ldgnum - "2" - difl: :type: real :intent: input :dims: - k - difr: :type: real :intent: input :dims: - ldgnum - "2" - z: :type: real :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: real :intent: input - s: :type: real :intent: input - work: :type: real :intent: workspace :dims: - k - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slalsa000077500000000000000000000174161325016550400166510ustar00rootroot00000000000000--- :name: slalsa :md5sum: 3817ef103afe5374c5f2833dfd84f267 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: real :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: real :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: real :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: real :intent: input :dims: - ldu - nlvl - difr: :type: real :intent: input :dims: - ldu - 2 * nlvl - z: :type: real :intent: input :dims: - ldu - nlvl - poles: :type: real :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: real :intent: input :dims: - ldu - 2 * nlvl - c: :type: real :intent: input :dims: - n - s: :type: real :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slalsd000077500000000000000000000121521325016550400166440ustar00rootroot00000000000000--- :name: slalsd :md5sum: 44fe2b5988c1444181a79736bc714030 :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slamrg000077500000000000000000000037301325016550400166510ustar00rootroot00000000000000--- :name: slamrg :md5sum: 0a48b06c5453d8e1f06057cc7369f5f8 :category: :subroutine :arguments: - n1: :type: integer :intent: input - n2: :type: integer :intent: input - a: :type: real :intent: input :dims: - n1+n2 - strd1: :type: integer :intent: input - strd2: :type: integer :intent: input - index: :type: integer :intent: output :dims: - n1+n2 :substitutions: {} :fortran_help: " 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 arguments 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" ruby-lapack-1.8.1/dev/defs/slaneg000077500000000000000000000053541325016550400166410ustar00rootroot00000000000000--- :name: slaneg :md5sum: b592b6c8f13d7dc0edca587a18aebd9f :category: :function :type: integer :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - lld: :type: real :intent: input :dims: - n-1 - sigma: :type: real :intent: input - pivmin: :type: real :intent: input - r: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slangb000077500000000000000000000055031325016550400166320ustar00rootroot00000000000000--- :name: slangb :md5sum: 3f8c81af777bb7ec2cc1b2625266d675 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slange000077500000000000000000000046761325016550400166470ustar00rootroot00000000000000--- :name: slange :md5sum: da9734ebe746c544e9ebeed6a02e5f99 :category: :function :type: real :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slangt000077500000000000000000000042241325016550400166530ustar00rootroot00000000000000--- :name: slangt :md5sum: b5fa6a1b7e062602baca818363a90bb4 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slanhs000077500000000000000000000045201325016550400166520ustar00rootroot00000000000000--- :name: slanhs :md5sum: e3c43e2100e6bef410d4ba5dc67db587 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slansb000077500000000000000000000062361325016550400166520ustar00rootroot00000000000000--- :name: slansb :md5sum: 3bbedb2fca11c6eb099b3bac2c12c03f :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slansf000077500000000000000000000145571325016550400166630ustar00rootroot00000000000000--- :name: slansf :md5sum: 014dd5ab8c3ce978110881e5d5f9d13b :category: :function :type: real :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"o\")) ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slansp000077500000000000000000000054461325016550400166720ustar00rootroot00000000000000--- :name: slansp :md5sum: 5f100ca86e29bd04042b892b3d73567a :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slanst000077500000000000000000000037671325016550400167020ustar00rootroot00000000000000--- :name: slanst :md5sum: cabf2b8182a1ceb35b27b12871092df3 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slansy000077500000000000000000000061051325016550400166740ustar00rootroot00000000000000--- :name: slansy :md5sum: 9ac8e2d4146d44485b5a4e92c90c712c :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slantb000077500000000000000000000070541325016550400166520ustar00rootroot00000000000000--- :name: slantb :md5sum: 7d0806eebdfcdd6789f9862ed9fa7fed :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slantp000077500000000000000000000061301325016550400166620ustar00rootroot00000000000000--- :name: slantp :md5sum: 7411f7e2611b351ddaa4eb97b833fb4f :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slantr000077500000000000000000000072521325016550400166720ustar00rootroot00000000000000--- :name: slantr :md5sum: f3ff0071196a89e069537cf5a2e623f8 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slanv2000077500000000000000000000045451325016550400165760ustar00rootroot00000000000000--- :name: slanv2 :md5sum: 8fbb15250e591974a48a0ab06ae552d1 :category: :subroutine :arguments: - a: :type: real :intent: input/output - b: :type: real :intent: input/output - c: :type: real :intent: input/output - d: :type: real :intent: input/output - rt1r: :type: real :intent: output - rt1i: :type: real :intent: output - rt2r: :type: real :intent: output - rt2i: :type: real :intent: output - cs: :type: real :intent: output - sn: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slapll000077500000000000000000000036331325016550400166550ustar00rootroot00000000000000--- :name: slapll :md5sum: fe9c0f015b103d941386cd6fd4c0cadd :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slapmr000077500000000000000000000040031325016550400166540ustar00rootroot00000000000000--- :name: slapmr :md5sum: 7ad0891c9d98cf5770f6ad81a1132d63 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slapmt000077500000000000000000000040061325016550400166610ustar00rootroot00000000000000--- :name: slapmt :md5sum: 26a344afe248a46fe200041a17590b53 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slapy2000077500000000000000000000012331325016550400165720ustar00rootroot00000000000000--- :name: slapy2 :md5sum: 4f1338cbdbf1dbb2f5736504748d4bf3 :category: :function :type: real :arguments: - x: :type: real :intent: input - y: :type: real :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slapy3000077500000000000000000000013571325016550400166020ustar00rootroot00000000000000--- :name: slapy3 :md5sum: d5b21d912addf1cf62c52c3a9cc2e387 :category: :function :type: real :arguments: - x: :type: real :intent: input - y: :type: real :intent: input - z: :type: real :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqgb000077500000000000000000000073111325016550400166340ustar00rootroot00000000000000--- :name: slaqgb :md5sum: 6f7c1c7791cc58c86bbce8fb18f95590 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqge000077500000000000000000000061151325016550400166400ustar00rootroot00000000000000--- :name: slaqge :md5sum: 93d81ef897fb1286b96cd6d41ebc4bef :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqp2000077500000000000000000000066301325016550400165700ustar00rootroot00000000000000--- :name: slaqp2 :md5sum: 082858bc789a3c8a0443b0df5a0a377a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - MIN(m,n) - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqps000077500000000000000000000100621325016550400166630ustar00rootroot00000000000000--- :name: slaqps :md5sum: de7dce7932e28c06c99614320e23e047 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - kb - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - auxv: :type: real :intent: input/output :dims: - nb - f: :type: real :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqr0000077500000000000000000000214501325016550400165650ustar00rootroot00000000000000--- :name: slaqr0 :md5sum: 7cd7bbe11e963bbdc8211e2516e9b634 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - ihi - wi: :type: real :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqr1000077500000000000000000000041251325016550400165660ustar00rootroot00000000000000--- :name: slaqr1 :md5sum: 9268bfacaf3cde6691ba9220ca02f6e0 :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: real :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - sr1: :type: real :intent: input - si1: :type: real :intent: input - sr2: :type: real :intent: input - si2: :type: real :intent: input - v: :type: real :intent: output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqr2000077500000000000000000000204411325016550400165660ustar00rootroot00000000000000--- :name: slaqr2 :md5sum: 541e85f74014b7b55bb36811cffb45db :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: real :intent: output :dims: - MAX(1,kbot) - si: :type: real :intent: output :dims: - MAX(1,kbot) - v: :type: real :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: real :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: real :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqr3000077500000000000000000000201031325016550400165620ustar00rootroot00000000000000--- :name: slaqr3 :md5sum: 488261ef65216cdb19827c02638e462d :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: real :intent: output :dims: - MAX(1,kbot) - si: :type: real :intent: output :dims: - MAX(1,kbot) - v: :type: real :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: real :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: real :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqr4000077500000000000000000000214501325016550400165710ustar00rootroot00000000000000--- :name: slaqr4 :md5sum: 9408e2dd3693791efc87fae05ebec6b6 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - ihi - wi: :type: real :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqr5000077500000000000000000000165351325016550400166020ustar00rootroot00000000000000--- :name: slaqr5 :md5sum: 57ca99e1b1f617787f2fa2e386337500 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - sr: :type: real :intent: input/output :dims: - nshfts - si: :type: real :intent: input/output :dims: - nshfts - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: real :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: real :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: real :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: real :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldz: n ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqsb000077500000000000000000000063511325016550400166530ustar00rootroot00000000000000--- :name: slaqsb :md5sum: d2d1a5396a266cc4eaa46bf3ff39ef25 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqsp000077500000000000000000000053111325016550400166640ustar00rootroot00000000000000--- :name: slaqsp :md5sum: 3614f64211713ef89af82dc2852fc696 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqsy000077500000000000000000000057441325016550400167070ustar00rootroot00000000000000--- :name: slaqsy :md5sum: a3447ffd7f39e12333b7d19bff28a03a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaqtr000077500000000000000000000101011325016550400166600ustar00rootroot00000000000000--- :name: slaqtr :md5sum: 01fae868ef726aad2b53e42607504b14 :category: :subroutine :arguments: - ltran: :type: logical :intent: input - lreal: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - b: :type: real :intent: input :dims: - n - w: :type: real :intent: input - scale: :type: real :intent: output - x: :type: real :intent: input/output :dims: - 2*n - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slar1v000077500000000000000000000145031325016550400165740ustar00rootroot00000000000000--- :name: slar1v :md5sum: 1fc0a916850c2048501bd4c9f734d5d1 :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: real :intent: input - d: :type: real :intent: input :dims: - n - l: :type: real :intent: input :dims: - n-1 - ld: :type: real :intent: input :dims: - n-1 - lld: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - gaptol: :type: real :intent: input - z: :type: real :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: real :intent: output - mingma: :type: real :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: real :intent: output - resid: :type: real :intent: output - rqcorr: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slar2v000077500000000000000000000045011325016550400165720ustar00rootroot00000000000000--- :name: slar2v :md5sum: 7102f5b9b61fb66f1047047d8464c701 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - y: :type: real :intent: input/output :dims: - 1+(n-1)*incx - z: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: real :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarf000077500000000000000000000047321325016550400164760ustar00rootroot00000000000000--- :name: slarf :md5sum: 7de47e1254ab712fc96ead026cb44b5f :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: real :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: real :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarfb000077500000000000000000000075661325016550400166500ustar00rootroot00000000000000--- :name: slarfb :md5sum: a289ad616cdb1dfb94da0a9070a5b91e :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: real :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/slarfg000077500000000000000000000035541325016550400166460ustar00rootroot00000000000000--- :name: slarfg :md5sum: 98062fabc987bc9e49a64e0408fef3cc :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: real :intent: input/output - x: :type: real :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarfgp000077500000000000000000000035351325016550400170250ustar00rootroot00000000000000--- :name: slarfgp :md5sum: b62217a99e255413ad1162ce4db07fd0 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: real :intent: input/output - x: :type: real :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarft000077500000000000000000000106771325016550400166670ustar00rootroot00000000000000--- :name: slarft :md5sum: b12d563ef62c069ed8eb5acdf578968b :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - t: :type: real :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarfx000077500000000000000000000045301325016550400166620ustar00rootroot00000000000000--- :name: slarfx :md5sum: b8357cd512a788dd72b74cc45e72bafe :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: real :intent: input :dims: - m - tau: :type: real :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slargv000077500000000000000000000036711325016550400166660ustar00rootroot00000000000000--- :name: slargv :md5sum: f561479469994456d10e2e31f244ecbb :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarnv000077500000000000000000000033351325016550400166720ustar00rootroot00000000000000--- :name: slarnv :md5sum: ec519a2c67aad07cda6a6014d8db7bf2 :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: real :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarra000077500000000000000000000064331325016550400166530ustar00rootroot00000000000000--- :name: slarra :md5sum: 8c265e4b5b823f839c614ef3bc019488 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input/output :dims: - n - e2: :type: real :intent: input/output :dims: - n - spltol: :type: real :intent: input - tnrm: :type: real :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarrb000077500000000000000000000123351325016550400166520ustar00rootroot00000000000000--- :name: slarrb :md5sum: ac43c9637a4b29c89256e616a3b9c674 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - lld: :type: real :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - offset: :type: integer :intent: input - w: :type: real :intent: input/output :dims: - n - wgap: :type: real :intent: input/output :dims: - n-1 - werr: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: real :intent: input - spdiam: :type: real :intent: input - twist: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarrc000077500000000000000000000053551325016550400166570ustar00rootroot00000000000000--- :name: slarrc :md5sum: 4fc70568a595ea2437abc06e26daf307 :category: :subroutine :arguments: - jobt: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n - pivmin: :type: real :intent: input - eigcnt: :type: integer :intent: output - lcnt: :type: integer :intent: output - rcnt: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarrd000077500000000000000000000256051325016550400166600ustar00rootroot00000000000000--- :name: slarrd :md5sum: 1d17cb93ea8bc4bff6584301e13e6ec7 :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - gers: :type: real :intent: input :dims: - 2*n - reltol: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - e2: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - nsplit: :type: integer :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - werr: :type: real :intent: output :dims: - n - wl: :type: real :intent: output - wu: :type: real :intent: output - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarre000077500000000000000000000221551325016550400166560ustar00rootroot00000000000000--- :name: slarre :md5sum: 98a7ef095c3e263ebe5088ca21b69c1a :category: :subroutine :arguments: - range: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input/output - vu: :type: real :intent: input/output - il: :type: integer :intent: input - iu: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - e2: :type: real :intent: input/output :dims: - n - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - spltol: :type: real :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - werr: :type: real :intent: output :dims: - n - wgap: :type: real :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - gers: :type: real :intent: output :dims: - 2*n - pivmin: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 6*n - iwork: :type: integer :intent: workspace :dims: - 5*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurred 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" ruby-lapack-1.8.1/dev/defs/slarrf000077500000000000000000000111621325016550400166530ustar00rootroot00000000000000--- :name: slarrf :md5sum: 04503ebe32bcc573b80d9d85b4382ab2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - l: :type: real :intent: input :dims: - n-1 - ld: :type: real :intent: input :dims: - n-1 - clstrt: :type: integer :intent: input - clend: :type: integer :intent: input - w: :type: real :intent: input :dims: - clend-clstrt+1 - wgap: :type: real :intent: input/output :dims: - clend-clstrt+1 - werr: :type: real :intent: input :dims: - clend-clstrt+1 - spdiam: :type: real :intent: input - clgapl: :type: real :intent: input - clgapr: :type: real :intent: input - pivmin: :type: real :intent: input - sigma: :type: real :intent: output - dplus: :type: real :intent: output :dims: - n - lplus: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 split).\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" ruby-lapack-1.8.1/dev/defs/slarrj000077500000000000000000000100061325016550400166530ustar00rootroot00000000000000--- :name: slarrj :md5sum: caa189892882955b2b29129c51865695 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e2: :type: real :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol: :type: real :intent: input - offset: :type: integer :intent: input - w: :type: real :intent: input/output :dims: - n - werr: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: real :intent: input - spdiam: :type: real :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarrk000077500000000000000000000061651325016550400166670ustar00rootroot00000000000000--- :name: slarrk :md5sum: 7b058d7040fa9f37d4d1ad325c612b1f :category: :subroutine :arguments: - n: :type: integer :intent: input - iw: :type: integer :intent: input - gl: :type: real :intent: input - gu: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e2: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - reltol: :type: real :intent: input - w: :type: real :intent: output - werr: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarrr000077500000000000000000000035731325016550400166760ustar00rootroot00000000000000--- :name: slarrr :md5sum: 2978dd436dee35812a8a2070f682419c :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarrv000077500000000000000000000220021325016550400166660ustar00rootroot00000000000000--- :name: slarrv :md5sum: c11cfd693c654d5325e306c9460e5b65 :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - d: :type: real :intent: input/output :dims: - n - l: :type: real :intent: input/output :dims: - n - pivmin: :type: real :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: real :intent: input - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - w: :type: real :intent: input/output :dims: - n - werr: :type: real :intent: input/output :dims: - n - wgap: :type: real :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: real :intent: input :dims: - 2*n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " 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 split.) 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 occurred 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" ruby-lapack-1.8.1/dev/defs/slarscl2000077500000000000000000000030001325016550400170770ustar00rootroot00000000000000--- :name: slarscl2 :md5sum: fa79e33c68ca79f44f598209626415d8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slartg000077500000000000000000000034221325016550400166560ustar00rootroot00000000000000--- :name: slartg :md5sum: 52b75639a9de491257810faa309579ab :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - cs: :type: real :intent: output - sn: :type: real :intent: output - r: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slartgp000077500000000000000000000032241325016550400170360ustar00rootroot00000000000000--- :name: slartgp :md5sum: 88a79da91a90b35ec8e235764f012f69 :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - cs: :type: real :intent: output - sn: :type: real :intent: output - r: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slartgs000077500000000000000000000027441325016550400170470ustar00rootroot00000000000000--- :name: slartgs :md5sum: b94e35bda8fd48cd94048c69f1af78f8 :category: :subroutine :arguments: - x: :type: real :intent: input - y: :type: real :intent: input - sigma: :type: real :intent: input - cs: :type: real :intent: output - sn: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slartv000077500000000000000000000041201325016550400166710ustar00rootroot00000000000000--- :name: slartv :md5sum: ecffa2fbeb30d3e551363e5757a136fa :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: real :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaruv000077500000000000000000000034401325016550400166760ustar00rootroot00000000000000--- :name: slaruv :md5sum: 83238be5ea5cc1426c39500d003d2f59 :category: :subroutine :arguments: - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: real :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarz000077500000000000000000000056571325016550400165310ustar00rootroot00000000000000--- :name: slarz :md5sum: 6000475d79cf0b1bd3de8df6c1d97c1f :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: real :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: real :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slarzb000077500000000000000000000102521325016550400166560ustar00rootroot00000000000000--- :name: slarzb :md5sum: 902d5ca8735017153470221c8083e9c9 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: real :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/slarzt000077500000000000000000000122271325016550400167040ustar00rootroot00000000000000--- :name: slarzt :md5sum: 81e19968d00efa646ad24673daeec8db :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - t: :type: real :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slas2000077500000000000000000000040201325016550400164010ustar00rootroot00000000000000--- :name: slas2 :md5sum: c614a835281cb4cc90907af6ff259ba5 :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - h: :type: real :intent: input - ssmin: :type: real :intent: output - ssmax: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slascl000077500000000000000000000063151325016550400166470ustar00rootroot00000000000000--- :name: slascl :md5sum: 1a4b40e8a10707c3896d8c7d4a610aac :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: real :intent: input - cto: :type: real :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slascl2000077500000000000000000000027541325016550400167340ustar00rootroot00000000000000--- :name: slascl2 :md5sum: 6db1e378bf1025bf179649e638ef1f6e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd0000077500000000000000000000077551325016550400165650ustar00rootroot00000000000000--- :name: slasd0 :md5sum: ee7a88d8d84c0475b3d0063f24187d61 :category: :subroutine :arguments: - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input :dims: - m-1 - u: :type: real :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - smlsiz: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - 8*n - work: :type: real :intent: workspace :dims: - 3*pow(m,2)+2*m - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldvt: m ldu: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd1000077500000000000000000000140241325016550400165510ustar00rootroot00000000000000--- :name: slasd1 :md5sum: a7c621c6eb8da974889c7dd9078eeeb9 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - nl+nr+1 - alpha: :type: real :intent: input/output - beta: :type: real :intent: input/output - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: real :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - idxq: :type: integer :intent: output :dims: - n - iwork: :type: integer :intent: workspace :dims: - 4*n - work: :type: real :intent: workspace :dims: - 3*pow(m,2)+2*m - info: :type: integer :intent: output :substitutions: m: n + sqre :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/slasd2000077500000000000000000000206571325016550400165630ustar00rootroot00000000000000--- :name: slasd2 :md5sum: e139bb4b0237d0c44116e11595e1c166 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: real :intent: input/output :dims: - n - z: :type: real :intent: output :dims: - n - alpha: :type: real :intent: input - beta: :type: real :intent: input - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: real :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - dsigma: :type: real :intent: output :dims: - n - u2: :type: real :intent: output :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt2: :type: real :intent: output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxp: :type: integer :intent: workspace :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxc: :type: integer :intent: output :dims: - n - idxq: :type: integer :intent: input/output :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldu2: n ldvt2: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd3000077500000000000000000000142451325016550400165600ustar00rootroot00000000000000--- :name: slasd3 :md5sum: b6481378b272a964c5ec577d73b4ac66 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: real :intent: output :dims: - k - q: :type: real :intent: workspace :dims: - ldq - k - ldq: :type: integer :intent: input - dsigma: :type: real :intent: input/output :dims: - k - u: :type: real :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - u2: :type: real :intent: input :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - vt2: :type: real :intent: input/output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxc: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - z: :type: real :intent: input/output :dims: - k - info: :type: integer :intent: output :substitutions: m: n+sqre ldq: k n: nl + nr + 1 ldu2: n ldvt: n ldvt2: n ldu: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd4000077500000000000000000000071201325016550400165530ustar00rootroot00000000000000--- :name: slasd4 :md5sum: 5d9cc23b9dcc49410cef1ca83143a336 :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - z: :type: real :intent: input :dims: - n - delta: :type: real :intent: output :dims: - n - rho: :type: real :intent: input - sigma: :type: real :intent: output - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd5000077500000000000000000000044641325016550400165640ustar00rootroot00000000000000--- :name: slasd5 :md5sum: a7b9ae7360e5f962ed9cb997a7a2fa1d :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - "2" - z: :type: real :intent: input :dims: - "2" - delta: :type: real :intent: output :dims: - "2" - rho: :type: real :intent: input - dsigma: :type: real :intent: output - work: :type: real :intent: workspace :dims: - "2" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd6000077500000000000000000000241451325016550400165630ustar00rootroot00000000000000--- :name: slasd6 :md5sum: 42e32de8791f7036090b24785a2bdb17 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - nl+nr+1 - vf: :type: real :intent: input/output :dims: - m - vl: :type: real :intent: input/output :dims: - m - alpha: :type: real :intent: input/output - beta: :type: real :intent: input/output - idxq: :type: integer :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: real :intent: output :dims: - ldgnum - "2" - difl: :type: real :intent: output :dims: - n - difr: :type: real :intent: output :dims: - "icompq == 1 ? ldgnum : icompq == 0 ? n : 0" - "icompq == 1 ? 2 : 0" - z: :type: real :intent: output :dims: - m - k: :type: integer :intent: output - c: :type: real :intent: output - s: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4 * m - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: m: n + sqre n: nl + nr + 1 ldgnum: n ldgcol: n :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/slasd7000077500000000000000000000201311325016550400165530ustar00rootroot00000000000000--- :name: slasd7 :md5sum: 1ef52169218289276f4f7b635e2435f4 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: real :intent: input/output :dims: - n - z: :type: real :intent: output :dims: - m - zw: :type: real :intent: workspace :dims: - m - vf: :type: real :intent: input/output :dims: - m - vfw: :type: real :intent: workspace :dims: - m - vl: :type: real :intent: input/output :dims: - m - vlw: :type: real :intent: workspace :dims: - m - alpha: :type: real :intent: input - beta: :type: real :intent: input - dsigma: :type: real :intent: output :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxp: :type: integer :intent: workspace :dims: - n - idxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - c: :type: real :intent: output - s: :type: real :intent: output - info: :type: integer :intent: output :substitutions: ldgnum: n ldgcol: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasd8000077500000000000000000000110761325016550400165640ustar00rootroot00000000000000--- :name: slasd8 :md5sum: 0427daa3f0dc3190e3b4094e1d06ca65 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: real :intent: output :dims: - k - z: :type: real :intent: input/output :dims: - k - vf: :type: real :intent: input/output :dims: - k - vl: :type: real :intent: input/output :dims: - k - difl: :type: real :intent: output :dims: - k - difr: :type: real :intent: output :dims: - "icompq == 1 ? lddifr : icompq == 0 ? k : 0" - "icompq == 1 ? 2 : 0" - lddifr: :type: integer :intent: input - dsigma: :type: real :intent: input/output :dims: - k - work: :type: real :intent: workspace :dims: - 3 * k - info: :type: integer :intent: output :substitutions: lddifr: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasda000077500000000000000000000220321325016550400166270ustar00rootroot00000000000000--- :name: slasda :md5sum: 7c5ff4bd16f613b9c5debfba98900d97 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input :dims: - m-1 - u: :type: real :intent: output :dims: - ldu - MAX(1,smlsiz) - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldu - smlsiz+1 - k: :type: integer :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - difl: :type: real :intent: output :dims: - ldu - nlvl - difr: :type: real :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? 2 * nlvl : 0" - z: :type: real :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? nlvl : 0" - poles: :type: real :intent: output :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: output :dims: - n - givcol: :type: integer :intent: output :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: output :dims: - ldgcol - nlvl - givnum: :type: real :intent: output :dims: - ldu - 2 * nlvl - c: :type: real :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - s: :type: real :intent: output :dims: - "icompq==1 ? n : icompq==0 ? 1 : 0" - work: :type: real :intent: workspace :dims: - 6 * n + (smlsiz + 1)*(smlsiz + 1) - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldu: n nlvl: floor(1.0/log(2.0)*log((double)n/smlsiz)) ldgcol: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasdq000077500000000000000000000144751325016550400166630ustar00rootroot00000000000000--- :name: slasdq :md5sum: ca31c86dcb1ae2e16419d7f2adab408a :category: :subroutine :arguments: - uplo: :type: char :intent: input - sqre: :type: integer :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - "sqre==0 ? n-1 : sqre==1 ? n : 0" - vt: :type: real :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 whether 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" ruby-lapack-1.8.1/dev/defs/slasdt000077500000000000000000000036411325016550400166570ustar00rootroot00000000000000--- :name: slasdt :md5sum: 5376f79e53fc9785b46d6951f8772790 :category: :subroutine :arguments: - n: :type: integer :intent: input - lvl: :type: integer :intent: output - nd: :type: integer :intent: output - inode: :type: integer :intent: output :dims: - MAX(1,n) - ndiml: :type: integer :intent: output :dims: - MAX(1,n) - ndimr: :type: integer :intent: output :dims: - MAX(1,n) - msub: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaset000077500000000000000000000047241325016550400166630ustar00rootroot00000000000000--- :name: slaset :md5sum: 28d3123066d541479be9ab6a5b21ab74 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - beta: :type: real :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasq1000077500000000000000000000046671325016550400166020ustar00rootroot00000000000000--- :name: slasq1 :md5sum: 37d790add72999bf796dea9d2b43e8e2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasq2000077500000000000000000000055751325016550400166020ustar00rootroot00000000000000--- :name: slasq2 :md5sum: 5a34b80f0830e1d378a257fe1013e49c :category: :subroutine :arguments: - n: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasq3000077500000000000000000000063051325016550400165730ustar00rootroot00000000000000--- :name: slasq3 :md5sum: 2f410ac97a48fb4a07e823012fc4b2d8 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input/output - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input/output - dmin: :type: real :intent: output - sigma: :type: real :intent: output - desig: :type: real :intent: input/output - qmax: :type: real :intent: input - nfail: :type: integer :intent: output - iter: :type: integer :intent: output - ndiv: :type: integer :intent: output - ieee: :type: logical :intent: input - ttype: :type: integer :intent: input/output - dmin1: :type: real :intent: input/output - dmin2: :type: real :intent: input/output - dn: :type: real :intent: input/output - dn1: :type: real :intent: input/output - dn2: :type: real :intent: input/output - g: :type: real :intent: input/output - tau: :type: real :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasq4000077500000000000000000000044071325016550400165750ustar00rootroot00000000000000--- :name: slasq4 :md5sum: 384541c9aca1ccacc332afa3badf712b :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - n0in: :type: integer :intent: input - dmin: :type: real :intent: input - dmin1: :type: real :intent: input - dmin2: :type: real :intent: input - dn: :type: real :intent: input - dn1: :type: real :intent: input - dn2: :type: real :intent: input - tau: :type: real :intent: output - ttype: :type: integer :intent: output - g: :type: real :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasq5000077500000000000000000000045251325016550400165770ustar00rootroot00000000000000--- :name: slasq5 :md5sum: a018da35dc7383c6ffddde2f88b68f5c :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - tau: :type: real :intent: input - dmin: :type: real :intent: output - dmin1: :type: real :intent: output - dmin2: :type: real :intent: output - dn: :type: real :intent: output - dnm1: :type: real :intent: output - dnm2: :type: real :intent: output - ieee: :type: logical :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasq6000077500000000000000000000043271325016550400166000ustar00rootroot00000000000000--- :name: slasq6 :md5sum: 04d0e31a5d0435c67ed105bcbe82323f :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - dmin: :type: real :intent: output - dmin1: :type: real :intent: output - dmin2: :type: real :intent: output - dn: :type: real :intent: output - dnm1: :type: real :intent: output - dnm2: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasr000077500000000000000000000140031325016550400165030ustar00rootroot00000000000000--- :name: slasr :md5sum: ff809128ca416b4d7f92c1ccd028ba23 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: real :intent: input :dims: - m-1 - s: :type: real :intent: input :dims: - m-1 - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasrt000077500000000000000000000027171325016550400167000ustar00rootroot00000000000000--- :name: slasrt :md5sum: 15c8d51a595bb1c0feca7da2d1cd0147 :category: :subroutine :arguments: - id: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slassq000077500000000000000000000040601325016550400166670ustar00rootroot00000000000000--- :name: slassq :md5sum: f995f8d885203d131171606c9c567d08 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: real :intent: input/output - sumsq: :type: real :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasv2000077500000000000000000000057151325016550400166030ustar00rootroot00000000000000--- :name: slasv2 :md5sum: b294da011aae849d462bb6da2189b9d9 :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - h: :type: real :intent: input - ssmin: :type: real :intent: output - ssmax: :type: real :intent: output - snr: :type: real :intent: output - csr: :type: real :intent: output - snl: :type: real :intent: output - csl: :type: real :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slaswp000077500000000000000000000044701325016550400166770ustar00rootroot00000000000000--- :name: slaswp :md5sum: a146d16e2844160e4ad408d072ac1b88 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasy2000077500000000000000000000077201325016550400166040ustar00rootroot00000000000000--- :name: slasy2 :md5sum: ae3def82cfd379e2cd0add43bc32316d :category: :subroutine :arguments: - ltranl: :type: logical :intent: input - ltranr: :type: logical :intent: input - isgn: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - tl: :type: real :intent: input :dims: - ldtl - "2" - ldtl: :type: integer :intent: input - tr: :type: real :intent: input :dims: - ldtr - "2" - ldtr: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - scale: :type: real :intent: output - x: :type: real :intent: output :dims: - ldx - "2" - ldx: :type: integer :intent: input - xnorm: :type: real :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n1) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slasyf000077500000000000000000000105421325016550400166640ustar00rootroot00000000000000--- :name: slasyf :md5sum: b2e9ac7bd81537a479ed47e04a559ad2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: real :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slatbs000077500000000000000000000167071325016550400166640ustar00rootroot00000000000000--- :name: slatbs :md5sum: 69ca3033afbf9a346aae44ab6b621fc0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slatdf000077500000000000000000000114321325016550400166370ustar00rootroot00000000000000--- :name: slatdf :md5sum: f15dc290a2df350b5b3f847a55798283 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: real :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: real :intent: input/output :dims: - n - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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 chosen 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" ruby-lapack-1.8.1/dev/defs/slatps000077500000000000000000000161031325016550400166700ustar00rootroot00000000000000--- :name: slatps :md5sum: 566e5a5dc28413e0003d6c0a705a6d4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - x: :type: real :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slatrd000077500000000000000000000137671325016550400166700ustar00rootroot00000000000000--- :name: slatrd :md5sum: c95f0cc9aadb9f343ff8ec7c58fd0f69 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - w: :type: real :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slatrs000077500000000000000000000167121325016550400167000ustar00rootroot00000000000000--- :name: slatrs :md5sum: 1a089a896f377a66e150c7a73da1b5d3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slatrz000077500000000000000000000065621325016550400167110ustar00rootroot00000000000000--- :name: slatrz :md5sum: 6a5023212b0ccc05fac79ef14eda05f2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - m - work: :type: real :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slatzm000077500000000000000000000071141325016550400166760ustar00rootroot00000000000000--- :name: slatzm :md5sum: 172c0c1f0dd2ca607bc873687a1c0d69 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: real :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: real :intent: input - c1: :type: real :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: real :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slauu2000077500000000000000000000041261325016550400165770ustar00rootroot00000000000000--- :name: slauu2 :md5sum: 5e2e54c06151826f884384f29c08e854 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/slauum000077500000000000000000000041241325016550400166700ustar00rootroot00000000000000--- :name: slauum :md5sum: ae3e332f4b2b2cd6e5a165d0d36c13a5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sopgtr000077500000000000000000000044151325016550400167030ustar00rootroot00000000000000--- :name: sopgtr :md5sum: 1353a948b585706cee42dbaad028b132 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - tau: :type: real :intent: input :dims: - ldtau - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sopmtr000077500000000000000000000070571325016550400167160ustar00rootroot00000000000000--- :name: sopmtr :md5sum: 4b67d05bda91d23c14cdd5edc2424ec8 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - m*(m+1)/2 - tau: :type: real :intent: input :dims: - m-1 - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorbdb000077500000000000000000000213441325016550400166400ustar00rootroot00000000000000--- :name: sorbdb :md5sum: 77f4a56e636c0e03cf3f7e9ce0710fd2 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: real :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: real :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: real :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: real :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - q - phi: :type: real :intent: output :dims: - q-1 - taup1: :type: real :intent: output :dims: - p - taup2: :type: real :intent: output :dims: - m-p - tauq1: :type: real :intent: output :dims: - q - tauq2: :type: real :intent: output :dims: - m-q - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorcsd000077500000000000000000000170711325016550400166640ustar00rootroot00000000000000--- :name: sorcsd :md5sum: 461218dc9a0e1a649087e4b8c78709c7 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: real :intent: input :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: real :intent: input :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: real :intent: input :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: real :intent: input :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: real :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: real :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: real :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: real :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" 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" p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorg2l000077500000000000000000000044071325016550400165760ustar00rootroot00000000000000--- :name: sorg2l :md5sum: 1b06659a1e359f99ff5b80f1bf6b9468 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorg2r000077500000000000000000000044031325016550400166000ustar00rootroot00000000000000--- :name: sorg2r :md5sum: be97ee24af78e97a228a26d00443a498 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgbr000077500000000000000000000104601325016550400166600ustar00rootroot00000000000000--- :name: sorgbr :md5sum: 04941c7af799ded94e7405ffcf964cc8 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - MIN(m,k) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorghr000077500000000000000000000055741325016550400167000ustar00rootroot00000000000000--- :name: sorghr :md5sum: 15d5df3b0bf735669e7d3581fa3c5dcb :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgl2000077500000000000000000000043501325016550400165730ustar00rootroot00000000000000--- :name: sorgl2 :md5sum: 5ca4164384b4e139924805aac6960789 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorglq000077500000000000000000000056421325016550400166770ustar00rootroot00000000000000--- :name: sorglq :md5sum: c0025a6efef362bff327d6a884154b3c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgql000077500000000000000000000057071325016550400167010ustar00rootroot00000000000000--- :name: sorgql :md5sum: f5008c1f6620c914e619887d4ba524d2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgqr000077500000000000000000000057031325016550400167030ustar00rootroot00000000000000--- :name: sorgqr :md5sum: 7ef8704c3983d6fc67c5358b41d724c9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgr2000077500000000000000000000043741325016550400166070ustar00rootroot00000000000000--- :name: sorgr2 :md5sum: 4206ad7b207c0443d7c85619b7300f0d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgrq000077500000000000000000000056661325016550400167130ustar00rootroot00000000000000--- :name: sorgrq :md5sum: 6a4e113034625a1fc6d7f18a8ca85de7 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorgtr000077500000000000000000000054601325016550400167060ustar00rootroot00000000000000--- :name: sorgtr :md5sum: c7c50b630620062c901712667ebb5d59 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorm2l000077500000000000000000000072111325016550400166000ustar00rootroot00000000000000--- :name: sorm2l :md5sum: 7a7499c55913697ee8e4843bc6dd133c :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorm2r000077500000000000000000000072121325016550400166070ustar00rootroot00000000000000--- :name: sorm2r :md5sum: c2847c0b1bf75f9216b6b3f5610d07de :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormbr000077500000000000000000000140241325016550400166660ustar00rootroot00000000000000--- :name: sormbr :md5sum: 30eacbb06a36a13208c27693866dce81 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - MIN(nq,k) - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormhr000077500000000000000000000121541325016550400166760ustar00rootroot00000000000000--- :name: sormhr :md5sum: 28091a9f0628e186adcb28eac6dffe34 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - m-1 - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sorml2000077500000000000000000000072441325016550400166060ustar00rootroot00000000000000--- :name: sorml2 :md5sum: 30a3da420120b18fe0d66742e041a3c1 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormlq000077500000000000000000000104631325016550400167020ustar00rootroot00000000000000--- :name: sormlq :md5sum: 9d63f013e5f6db69178cf57382540251 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormql000077500000000000000000000104301325016550400166740ustar00rootroot00000000000000--- :name: sormql :md5sum: 82e0f91f76caa378359d0a433113338f :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormqr000077500000000000000000000104311325016550400167030ustar00rootroot00000000000000--- :name: sormqr :md5sum: 67964f86905e74bb1a25c5c33745dd83 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormr2000077500000000000000000000072431325016550400166130ustar00rootroot00000000000000--- :name: sormr2 :md5sum: 5fd8bdc69537641d2383d642976a1f39 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormr3000077500000000000000000000110451325016550400166070ustar00rootroot00000000000000--- :name: sormr3 :md5sum: 7f39e6e76399d353e330f71975ab640d :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormrq000077500000000000000000000104621325016550400167070ustar00rootroot00000000000000--- :name: sormrq :md5sum: c9ce5049cc64eea5a906b4441ebbcde8 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormrz000077500000000000000000000114011325016550400167120ustar00rootroot00000000000000--- :name: sormrz :md5sum: 86e71e8e355df05ea115b509d2d2733c :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sormtr000077500000000000000000000116111325016550400167070ustar00rootroot00000000000000--- :name: sormtr :md5sum: 5c0d297be3b21e4f035a0da2f474fb36 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - m-1 - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbcon000077500000000000000000000057351325016550400166570ustar00rootroot00000000000000--- :name: spbcon :md5sum: d503557674f04f3c66bdda5c815f8d48 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbequ000077500000000000000000000061741325016550400166700ustar00rootroot00000000000000--- :name: spbequ :md5sum: fcd294fd62071c4dcdc44bab541045fc :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbrfs000077500000000000000000000117171325016550400166670ustar00rootroot00000000000000--- :name: spbrfs :md5sum: b02855b62236c3e7a01af09522487131 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbstf000077500000000000000000000076301325016550400166700ustar00rootroot00000000000000--- :name: spbstf :md5sum: 4015e93b6c7ebd85726713ac3fabd501 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbsv000077500000000000000000000113661325016550400165250ustar00rootroot00000000000000--- :name: spbsv :md5sum: 4407c9056bcf43a0932a2e1a7a03fb8a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbsvx000077500000000000000000000274151325016550400167170ustar00rootroot00000000000000--- :name: spbsvx :md5sum: 3f219c9aaa3650653085d61fe2a5f6c7 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbtf2000077500000000000000000000071041325016550400165630ustar00rootroot00000000000000--- :name: spbtf2 :md5sum: 60a9f976698f8a9e6d64eb1bc045f8d4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbtrf000077500000000000000000000067411325016550400166710ustar00rootroot00000000000000--- :name: spbtrf :md5sum: d8a847b41ef3b56bb1ee6cfc241034bd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spbtrs000077500000000000000000000060621325016550400167020ustar00rootroot00000000000000--- :name: spbtrs :md5sum: 5c0eafb2b3376474927b22c92ecdf413 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spftrf000077500000000000000000000141201325016550400166630ustar00rootroot00000000000000--- :name: spftrf :md5sum: d1c6046e8099759e3e26aad67c90017d :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spftri000077500000000000000000000134661325016550400167020ustar00rootroot00000000000000--- :name: spftri :md5sum: 7350ee23c49766041a290bde8cbe7e2e :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spftrs000077500000000000000000000131421325016550400167030ustar00rootroot00000000000000--- :name: spftrs :md5sum: 59ce631df9d7e1b4bd116b5447fce8c2 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spocon000077500000000000000000000046371325016550400166740ustar00rootroot00000000000000--- :name: spocon :md5sum: a8e596611b25d484e9d2cf8ee1b2f6c1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spoequ000077500000000000000000000047561325016550400167110ustar00rootroot00000000000000--- :name: spoequ :md5sum: 126e431bf7b286f0e96b4a6356abcc11 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spoequb000077500000000000000000000047601325016550400170460ustar00rootroot00000000000000--- :name: spoequb :md5sum: 4aa28db9fad2c9d00f35b7d240b9c359 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sporfs000077500000000000000000000113521325016550400166770ustar00rootroot00000000000000--- :name: sporfs :md5sum: 2da5772e924df961dace1e5733835a98 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sporfsx000077500000000000000000000365641325016550400171030ustar00rootroot00000000000000--- :name: sporfsx :md5sum: aa5a8957ca3223e6fa42b338a9f77adb :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sposv000077500000000000000000000070301325016550400165330ustar00rootroot00000000000000--- :name: sposv :md5sum: 68e02f39eeec630778ac5a25a9500f3c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sposvx000077500000000000000000000254521325016550400167330ustar00rootroot00000000000000--- :name: sposvx :md5sum: 378892e498244c50b29908f4f7980ff2 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sposvxx000077500000000000000000000505111325016550400171150ustar00rootroot00000000000000--- :name: sposvxx :md5sum: 39688c3da1b5c667774c67ca0d177f17 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/spotf2000077500000000000000000000047021325016550400166010ustar00rootroot00000000000000--- :name: spotf2 :md5sum: ff11b64a0a68b9efbd6f0735f97b2e3c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spotrf000077500000000000000000000045531325016550400167050ustar00rootroot00000000000000--- :name: spotrf :md5sum: cb97be44d916cb601b672d4d31893ab1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spotri000077500000000000000000000041151325016550400167020ustar00rootroot00000000000000--- :name: spotri :md5sum: 25b6d8f49368c27482c933dfa5623c9b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spotrs000077500000000000000000000041601325016550400167140ustar00rootroot00000000000000--- :name: spotrs :md5sum: 682fff75d60d2fbfbef656486b39b556 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sppcon000077500000000000000000000050541325016550400166670ustar00rootroot00000000000000--- :name: sppcon :md5sum: 98f94f1d8ffd2bf4f13ec248609b1c13 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sppequ000077500000000000000000000053451325016550400167050ustar00rootroot00000000000000--- :name: sppequ :md5sum: dd4a1d4820fa068a3609978bd96479a3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spprfs000077500000000000000000000106271325016550400167040ustar00rootroot00000000000000--- :name: spprfs :md5sum: 2eeef5bb7a81f158e895ae7daf58f68c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - afp: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sppsv000077500000000000000000000075341325016550400165450ustar00rootroot00000000000000--- :name: sppsv :md5sum: 87516007e377bd390aec2344e7fd7157 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sppsvx000077500000000000000000000256321325016550400167340ustar00rootroot00000000000000--- :name: sppsvx :md5sum: f166a0980453efbc2cb1d3eed8b18771 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - afp: :type: real :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spptrf000077500000000000000000000051401325016550400166770ustar00rootroot00000000000000--- :name: spptrf :md5sum: 23562c90317eb8bef1a4a57d96a58691 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spptri000077500000000000000000000036241325016550400167070ustar00rootroot00000000000000--- :name: spptri :md5sum: 43cff036bbefeae28ea091a5a1aa282e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spptrs000077500000000000000000000051561325016550400167230ustar00rootroot00000000000000--- :name: spptrs :md5sum: 87799d8280769b5abe7f899985cf3927 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spstf2000077500000000000000000000067311325016550400166110ustar00rootroot00000000000000--- :name: spstf2 :md5sum: 7c3f23878642ae0aa4302ae0bd2848c1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spstrf000077500000000000000000000067271325016550400167160ustar00rootroot00000000000000--- :name: spstrf :md5sum: 3aace2c5c80392dcbc18630e0ce90642 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sptcon000077500000000000000000000046711325016550400166770ustar00rootroot00000000000000--- :name: sptcon :md5sum: 5a00e16f6815275367e352669482c2d2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spteqr000077500000000000000000000104071325016550400167010ustar00rootroot00000000000000--- :name: spteqr :md5sum: 602a7d1d94751729b99e8b4b6eb7a9b3 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sptrfs000077500000000000000000000076551325016550400167170ustar00rootroot00000000000000--- :name: sptrfs :md5sum: 4ecbb01d7ec0c479ca08bee758afed59 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - df: :type: real :intent: input :dims: - n - ef: :type: real :intent: input :dims: - n-1 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sptsv000077500000000000000000000056401325016550400165450ustar00rootroot00000000000000--- :name: sptsv :md5sum: b5b44ec0183117f08df71d104487fade :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sptsvx000077500000000000000000000161761325016550400167430ustar00rootroot00000000000000--- :name: sptsvx :md5sum: 25937351c61902c902d4672751abaf55 :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - df: :type: real :intent: input/output :dims: - n - ef: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spttrf000077500000000000000000000037201325016550400167050ustar00rootroot00000000000000--- :name: spttrf :md5sum: 47f8d0a8b02124ba7683b1ce91574c41 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/spttrs000077500000000000000000000052501325016550400167220ustar00rootroot00000000000000--- :name: spttrs :md5sum: f2c3d76783e9838492aa35a5bd7101fa :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sptts2000077500000000000000000000044031325016550400166210ustar00rootroot00000000000000--- :name: sptts2 :md5sum: 2e63425e2f920d91557419030f1e2e1b :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/srscl000077500000000000000000000025611325016550400165130ustar00rootroot00000000000000--- :name: srscl :md5sum: 45d3ebae0bf847fdef2d0c541c71e3e8 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: real :intent: input - sx: :type: real :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbev000077500000000000000000000073161325016550400165120ustar00rootroot00000000000000--- :name: ssbev :md5sum: c21bb96306e38603fdb5434c2dc4066f :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbevd000077500000000000000000000142021325016550400166460ustar00rootroot00000000000000--- :name: ssbevd :md5sum: 71100f8057bbfe6a4838357d0d1b2105 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbevx000077500000000000000000000200241325016550400166710ustar00rootroot00000000000000--- :name: ssbevx :md5sum: 5bc1377ca79aec6da21ebd73878121f8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbgst000077500000000000000000000076131325016550400166750ustar00rootroot00000000000000--- :name: ssbgst :md5sum: 14370d921ebcc0d145ab5ead41aee089 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbgv000077500000000000000000000125461325016550400165150ustar00rootroot00000000000000--- :name: ssbgv :md5sum: fc134831f389ed655ad11545afbcdfa8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbgvd000077500000000000000000000167001325016550400166550ustar00rootroot00000000000000--- :name: ssbgvd :md5sum: 5bfbda491946682057cb1045bd9f84a5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssbgvx000077500000000000000000000215111325016550400166750ustar00rootroot00000000000000--- :name: ssbgvx :md5sum: 6533cca6ce1f6994105411b520fc7ed2 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - 7*n - iwork: :type: integer :intent: output :dims: - 5*n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :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" :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\ *\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" ruby-lapack-1.8.1/dev/defs/ssbtrd000077500000000000000000000100131325016550400166550ustar00rootroot00000000000000--- :name: ssbtrd :md5sum: 4d2b2c94a4720f12c22cbd1420997ff4 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssfrk000077500000000000000000000101121325016550400165040ustar00rootroot00000000000000--- :name: ssfrk :md5sum: 5b5f4cafc518b82b9b7304e9cd5c0721 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - "(lsame_(&trans,\"N\") || lsame_(&trans,\"n\")) ? k : n" - lda: :type: integer :intent: input - beta: :type: real :intent: input - c: :type: real :intent: input/output :dims: - nt :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspcon000077500000000000000000000052361325016550400166740ustar00rootroot00000000000000--- :name: sspcon :md5sum: be9e7176a45065d4328b9ed8b007eba9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspev000077500000000000000000000064421325016550400165270ustar00rootroot00000000000000--- :name: sspev :md5sum: 190815c126e8cc58da7d9d497f9d0050 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspevd000077500000000000000000000133171325016550400166720ustar00rootroot00000000000000--- :name: sspevd :md5sum: 83441e80c70bbab2f5bee13cf131faa6 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspevx000077500000000000000000000160151325016550400167140ustar00rootroot00000000000000--- :name: sspevx :md5sum: b52fee75951227849a69f57900d7636b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspgst000077500000000000000000000050731325016550400167110ustar00rootroot00000000000000--- :name: sspgst :md5sum: 33ef68fb9b8c97de9d8d99a2aa5d9f90 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - bp: :type: real :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspgv000077500000000000000000000116461325016550400165330ustar00rootroot00000000000000--- :name: sspgv :md5sum: b3c519ead837e7b587434eb8d06cec29 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - bp: :type: real :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspgvd000077500000000000000000000157431325016550400167010ustar00rootroot00000000000000--- :name: sspgvd :md5sum: 97ec12398c858d8e33458a3e860d2815 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - bp: :type: real :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspgvx000077500000000000000000000217251325016550400167220ustar00rootroot00000000000000--- :name: sspgvx :md5sum: f1e22435b9665fcf555d8758dff89446 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - bp: :type: real :intent: input/output :dims: - n*(n+1)/2 - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssprfs000077500000000000000000000113121325016550400166770ustar00rootroot00000000000000--- :name: ssprfs :md5sum: 4b6b3373fef866ff285dcb698532f7bd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - afp: :type: real :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspsv000077500000000000000000000115121325016550400165370ustar00rootroot00000000000000--- :name: sspsv :md5sum: 49f355fd85c3827ba9c219ecf5984c77 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sspsvx000077500000000000000000000225201325016550400167300ustar00rootroot00000000000000--- :name: sspsvx :md5sum: f706bfdee518e2325df5f40d8aa62f3c :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - afp: :type: real :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssptrd000077500000000000000000000076311325016550400167070ustar00rootroot00000000000000--- :name: ssptrd :md5sum: 055e7259054806f91d37ece62e2b52e5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssptrf000077500000000000000000000115361325016550400167100ustar00rootroot00000000000000--- :name: ssptrf :md5sum: d4d9ba30e2725b29813df249be3729ce :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssptri000077500000000000000000000046721325016550400167160ustar00rootroot00000000000000--- :name: ssptri :md5sum: 253eb732f2689ac417f212ba2df196b9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssptrs000077500000000000000000000046261325016550400167270ustar00rootroot00000000000000--- :name: ssptrs :md5sum: 0f123f21a75d567b16fa17a541053358 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstebz000077500000000000000000000214571325016550400167040ustar00rootroot00000000000000--- :name: sstebz :md5sum: b5160a4860997c0b386672e043c097b0 :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - m: :type: integer :intent: output - nsplit: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - isplit: :type: integer :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstedc000077500000000000000000000147371325016550400166620ustar00rootroot00000000000000--- :name: sstedc :md5sum: 9818f0520ca5590cf0b25092ba9cd955 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstegr000077500000000000000000000205461325016550400166770ustar00rootroot00000000000000--- :name: sstegr :md5sum: 992b1604b86ed979e0de63b7c057e36b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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 compatibility 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" ruby-lapack-1.8.1/dev/defs/sstein000077500000000000000000000112251325016550400166670ustar00rootroot00000000000000--- :name: sstein :md5sum: bbffab0892513273e4f820370b48ca83 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: real :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: real :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstemr000077500000000000000000000273461325016550400167120ustar00rootroot00000000000000--- :name: sstemr :md5sum: 2493f4287dcea620213b2c3c882bda51 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssteqr000077500000000000000000000071431325016550400167070ustar00rootroot00000000000000--- :name: ssteqr :md5sum: 75323c7177adfd9bb0df92567a13acaf :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssterf000077500000000000000000000031141325016550400166660ustar00rootroot00000000000000--- :name: ssterf :md5sum: 5ff23162e652c9a2477b1e5c9764dc26 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstev000077500000000000000000000051731325016550400165330ustar00rootroot00000000000000--- :name: sstev :md5sum: 51a1acebfd740cd57ebd5d2033013bbe :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&jobz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstevd000077500000000000000000000116301325016550400166720ustar00rootroot00000000000000--- :name: sstevd :md5sum: 10d00bce80e4d19bfdeff93402e6c8f0 :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstevr000077500000000000000000000247521325016550400167210ustar00rootroot00000000000000--- :name: sstevr :md5sum: e5ea156e311e0d701679c0e4fa1a3c85 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - MAX(1,n-1) - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 20*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/sstevx000077500000000000000000000151441325016550400167220ustar00rootroot00000000000000--- :name: sstevx :md5sum: 0ce5fc8494230896d0287e84e6702aff :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - MAX(1,n-1) - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssycon000077500000000000000000000053771325016550400167130ustar00rootroot00000000000000--- :name: ssycon :md5sum: a6c3acc99557360e216bc35bcb78abd5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyconv000077500000000000000000000050711325016550400170700ustar00rootroot00000000000000--- :name: ssyconv :md5sum: 119fb0834f75cb8910761daec667bf8a :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyequb000077500000000000000000000064141325016550400170610ustar00rootroot00000000000000--- :name: ssyequb :md5sum: f38f288f9e8b71ede27c0a88d4d0021f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyev000077500000000000000000000065461325016550400165450ustar00rootroot00000000000000--- :name: ssyev :md5sum: b3e09603e880a722d95069c7c92b63df :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyevd000077500000000000000000000135611325016550400167040ustar00rootroot00000000000000--- :name: ssyevd :md5sum: e10c9634d1a916940bd4f1bd51d00aed :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyevr000077500000000000000000000301351325016550400167160ustar00rootroot00000000000000--- :name: ssyevr :md5sum: aeda6b168ea42a1a378f58c635a709cc :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 26*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyevx000077500000000000000000000172741325016550400167350ustar00rootroot00000000000000--- :name: ssyevx :md5sum: 875e9aa1a6f008f17488a10fac754ad6 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 8*n" - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssygs2000077500000000000000000000057231325016550400166220ustar00rootroot00000000000000--- :name: ssygs2 :md5sum: 42826111a4afb91aa5b98c358b60a0b2 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssygst000077500000000000000000000057201325016550400167210ustar00rootroot00000000000000--- :name: ssygst :md5sum: 710385c5ac37be3867975f6350fe08d6 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssygv000077500000000000000000000123251325016550400165370ustar00rootroot00000000000000--- :name: ssygv :md5sum: 1003382acfdb1e9d9c4540ae84151723 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssygvd000077500000000000000000000171551325016550400167110ustar00rootroot00000000000000--- :name: ssygvd :md5sum: 89917a8e36f69459391a1b240a601bff :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssygvx000077500000000000000000000230631325016550400167300ustar00rootroot00000000000000--- :name: ssygvx :md5sum: 997610aae4bc990e7bf530106e272869 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - lda - n - ldb: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyrfs000077500000000000000000000121201325016550400167060ustar00rootroot00000000000000--- :name: ssyrfs :md5sum: 3c7cbc979f08d480fd7cfb5e0839f8ff :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssyrfsx000077500000000000000000000373021325016550400171070ustar00rootroot00000000000000--- :name: ssyrfsx :md5sum: dfa0d302a32611400da950bcd1072380 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssysv000077500000000000000000000127151325016550400165560ustar00rootroot00000000000000--- :name: ssysv :md5sum: 3e9925aac8d350c2ab75099826bbc8f9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssysvx000077500000000000000000000233431325016550400167450ustar00rootroot00000000000000--- :name: ssysvx :md5sum: 04e4eb2438011793b7546b2ee981c6e3 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssysvxx000077500000000000000000000514711325016550400171400ustar00rootroot00000000000000--- :name: ssysvxx :md5sum: 8aeecdaa231d926cc3ca72197ec9883e :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/ssyswapr000077500000000000000000000043341325016550400172600ustar00rootroot00000000000000--- :name: ssyswapr :md5sum: 8d75fd067b15a4894a7b7b15f0c13b2d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytd2000077500000000000000000000115251325016550400166150ustar00rootroot00000000000000--- :name: ssytd2 :md5sum: 29aaa26fad35e07fd904dc42d2c17119 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytf2000077500000000000000000000132161325016550400166160ustar00rootroot00000000000000--- :name: ssytf2 :md5sum: b890ad730f432e7fd43aafe12b906d1b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytrd000077500000000000000000000130421325016550400167110ustar00rootroot00000000000000--- :name: ssytrd :md5sum: b138e11daf348714582c26e44231dbd9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytrf000077500000000000000000000144471325016550400167250ustar00rootroot00000000000000--- :name: ssytrf :md5sum: 838bea0e137071d39a87657d7a1c49ee :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytri000077500000000000000000000050361325016550400167220ustar00rootroot00000000000000--- :name: ssytri :md5sum: c1b48ee1c822859d4ff01e02baede991 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytri2000077500000000000000000000073271325016550400170110ustar00rootroot00000000000000--- :name: ssytri2 :md5sum: f7557065622ea4dc05dffeeac6fa1e18 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" nb: ilaenv_(&c__1, "SSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytri2x000077500000000000000000000052571325016550400172010ustar00rootroot00000000000000--- :name: ssytri2x :md5sum: 93ce2bf66c6e6089e4300945dd132c6b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytrs000077500000000000000000000047471325016550400167440ustar00rootroot00000000000000--- :name: ssytrs :md5sum: 20324ae4a550ed249f9ba27d627ce9cd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ssytrs2000077500000000000000000000052131325016550400170130ustar00rootroot00000000000000--- :name: ssytrs2 :md5sum: ed50028299accd66eae8dd53a98b6eb0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stbcon000077500000000000000000000062431325016550400166560ustar00rootroot00000000000000--- :name: stbcon :md5sum: a27a8931aed80bb492d80c96ccc10853 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stbrfs000077500000000000000000000116431325016550400166710ustar00rootroot00000000000000--- :name: stbrfs :md5sum: 2e9b692379fa03625583395df789da2f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stbtrs000077500000000000000000000066331325016550400167120ustar00rootroot00000000000000--- :name: stbtrs :md5sum: dad3e4876ded9e7c7b27950c40311c22 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stfsm000077500000000000000000000210701325016550400165150ustar00rootroot00000000000000--- :name: stfsm :md5sum: 1dcdb7177f893a4f654c7e71cf9bfb56 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - nt - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stftri000077500000000000000000000140251325016550400166760ustar00rootroot00000000000000--- :name: stftri :md5sum: 8257ba2b58870bddeb55353c065e8aa5 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stfttp000077500000000000000000000124301325016550400167050ustar00rootroot00000000000000--- :name: stfttp :md5sum: 8b5cd27ac481472cc0220e19615f2a63 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: real :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: real :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stfttr000077500000000000000000000142471325016550400167170ustar00rootroot00000000000000--- :name: stfttr :md5sum: df86973ab0132ff43480f353386b9f62 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: real :intent: input :dims: - ldarf - a: :type: real :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldarf*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgevc000077500000000000000000000235551325016550400166660ustar00rootroot00000000000000--- :name: stgevc :md5sum: 0a4f8003fe9e7bdf3a2db60d8dcd9b6f :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: real :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: real :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: real :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: real :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - 6*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgex2000077500000000000000000000141261325016550400166010ustar00rootroot00000000000000--- :name: stgex2 :md5sum: 0ff12ef41f70e923d7440270d8c9e9f1 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(n*(n2+n1), (n2+n1)*(n2+n1)*2) - info: :type: integer :intent: output :substitutions: lwork: MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2))) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgexc000077500000000000000000000143531325016550400166640ustar00rootroot00000000000000--- :name: stgexc :md5sum: 5d3e5cea4ba4800679b5eae4b7a67cc3 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 4*n+16" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgsen000077500000000000000000000414601325016550400166710ustar00rootroot00000000000000--- :name: stgsen :md5sum: 679c7e17ebcfb834ce7dd42f2eb8a2b1 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: real :intent: output - pr: :type: real :intent: output - dif: :type: real :intent: output :dims: - "2" - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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: - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgsja000077500000000000000000000256321325016550400166640ustar00rootroot00000000000000--- :name: stgsja :md5sum: 604149ded91900c1bd601ad488246cc2 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: real :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgsna000077500000000000000000000326211325016550400166640ustar00rootroot00000000000000--- :name: stgsna :md5sum: df29cdbd8fb6f9df1af4856bd8b8b717 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: real :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: real :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - dif: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n + 6" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgsy2000077500000000000000000000206161325016550400166210ustar00rootroot00000000000000--- :name: stgsy2 :md5sum: 649807c96dfdbfb124fdd5574fd71dd9 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: real :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: real :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: real :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - iwork: :type: integer :intent: workspace :dims: - m+n+2 - pq: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stgsyl000077500000000000000000000225511325016550400167130ustar00rootroot00000000000000--- :name: stgsyl :md5sum: 590e8de996b4d8d7c05f6e8b21245a75 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: real :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: real :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: real :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - dif: :type: real :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+6 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stpcon000077500000000000000000000054471325016550400167010ustar00rootroot00000000000000--- :name: stpcon :md5sum: 67bae0432923c2a291efa3e2bea0d816 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stprfs000077500000000000000000000110231325016550400166770ustar00rootroot00000000000000--- :name: stprfs :md5sum: f24b1ca96348a27a0f29020ea208cd14 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stptri000077500000000000000000000051751325016550400167160ustar00rootroot00000000000000--- :name: stptri :md5sum: 1651295dca8d52ec141a000d61e66fe5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stptrs000077500000000000000000000056611325016550400167300ustar00rootroot00000000000000--- :name: stptrs :md5sum: 780738733718513efa60d63a4f9ef31f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stpttf000077500000000000000000000124611325016550400167110ustar00rootroot00000000000000--- :name: stpttf :md5sum: bee582ac0fc39454a04971af8851b644 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: real :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stpttr000077500000000000000000000044141325016550400167240ustar00rootroot00000000000000--- :name: stpttr :md5sum: 9c07897dfa04ac8ad6c902bcba53ac0d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - a: :type: real :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strcon000077500000000000000000000060601325016550400166730ustar00rootroot00000000000000--- :name: strcon :md5sum: 1e27ff979acf125159e35c01ddb03755 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strevc000077500000000000000000000160341325016550400166730ustar00rootroot00000000000000--- :name: strevc :md5sum: 0d2d5d1a609c10f4ee3c5f0b43c8a755 :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: real :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: real :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strexc000077500000000000000000000074041325016550400166760ustar00rootroot00000000000000--- :name: strexc :md5sum: a068be55bb498b1fa71d32054496ba06 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strrfs000077500000000000000000000114601325016550400167060ustar00rootroot00000000000000--- :name: strrfs :md5sum: 77120e9b758c0a89a337b22b4a383886 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strsen000077500000000000000000000255021325016550400167030ustar00rootroot00000000000000--- :name: strsen :md5sum: dffc2bc2dac37c71e5e862aa4bf0cc53 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: real :intent: output - sep: :type: real :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strsna000077500000000000000000000206301325016550400166740ustar00rootroot00000000000000--- :name: strsna :md5sum: 1e372d5e18a7cb4bcbdd88ae0cc3766b :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: real :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: real :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - sep: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : 2*(n-1)" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strsyl000077500000000000000000000077461325016550400167370ustar00rootroot00000000000000--- :name: strsyl :md5sum: 650bfc17167d0bb5e57a982981f61818 :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strti2000077500000000000000000000045331325016550400166150ustar00rootroot00000000000000--- :name: strti2 :md5sum: 1d4a26588f70037999cb08613ada275d :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strtri000077500000000000000000000045561325016550400167220ustar00rootroot00000000000000--- :name: strtri :md5sum: 26267687ec50d1af53ee98df1e50ae79 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strtrs000077500000000000000000000064551325016550400167340ustar00rootroot00000000000000--- :name: strtrs :md5sum: f97db8918b10773428e9be5886041cc4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strttf000077500000000000000000000140141325016550400167070ustar00rootroot00000000000000--- :name: strttf :md5sum: 22b37df5c63942034431b6f79e1e3a0d :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: real :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/strttp000077500000000000000000000043321325016550400167230ustar00rootroot00000000000000--- :name: strttp :md5sum: 952a2e28ec06b1b31c0e79c0f031dff9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: real :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stzrqf000077500000000000000000000063761325016550400167260ustar00rootroot00000000000000--- :name: stzrqf :md5sum: 3c659a74cdb37ba1b3d0655fa6394118 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/stzrzf000077500000000000000000000101471325016550400167260ustar00rootroot00000000000000--- :name: stzrzf :md5sum: 23ccaffcdd27808e21475d8e506f3e5d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - m - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/xerbla000077500000000000000000000022031325016550400166330ustar00rootroot00000000000000--- :name: xerbla :md5sum: 8669c67841523ada1fea62672f940583 :category: :subroutine :arguments: - srname: :type: char :intent: input :dims: - "*" - info: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/xerbla_array000077500000000000000000000042721325016550400200410ustar00rootroot00000000000000--- :name: xerbla_array :md5sum: 320702fa47907817bf73aecb5577c631 :category: :subroutine :arguments: - srname_array: :type: char :intent: input :dims: - srname_len - srname_len: :type: integer :intent: input - info: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zbbcsd000077500000000000000000000225261325016550400166370ustar00rootroot00000000000000--- :name: zbbcsd :md5sum: 9a65726a037b363eb2c0b9c63517765d :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: doublereal :intent: input/output :dims: - q - phi: :type: doublereal :intent: input :dims: - q-1 - u1: :type: doublecomplex :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: doublecomplex :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublecomplex :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: doublecomplex :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: doublereal :intent: output :dims: - q - b11e: :type: doublereal :intent: output :dims: - q-1 - b12d: :type: doublereal :intent: output :dims: - q - b12e: :type: doublereal :intent: output :dims: - q-1 - b21d: :type: doublereal :intent: output :dims: - q - b21e: :type: doublereal :intent: output :dims: - q-1 - b22d: :type: doublereal :intent: output :dims: - q - b22e: :type: doublereal :intent: output :dims: - q-1 - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: lrwork: MAX(1,8*q) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zbdsqr000077500000000000000000000160711325016550400166730ustar00rootroot00000000000000--- :name: zbdsqr :md5sum: f9942566ea058ea5036793480cdaa22c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - vt: :type: doublecomplex :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: doublecomplex :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - "(ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zcgesv000077500000000000000000000141541325016550400166670ustar00rootroot00000000000000--- :name: zcgesv :md5sum: bdec37d073bdd6753df626ef86ae37b2 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n*nrhs - swork: :type: complex :intent: workspace :dims: - n*(n+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - n - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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 successfully 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" ruby-lapack-1.8.1/dev/defs/zcposv000077500000000000000000000146451325016550400167170ustar00rootroot00000000000000--- :name: zcposv :md5sum: f63123d92c2b19650e7f886a8530407f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n*nrhs - swork: :type: complex :intent: workspace :dims: - n*(n+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - n - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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 successfully 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" ruby-lapack-1.8.1/dev/defs/zdrscl000077500000000000000000000026311325016550400166640ustar00rootroot00000000000000--- :name: zdrscl :md5sum: e7cb13451d543134640cbced3e3cc991 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: doublereal :intent: input - sx: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbbrd000077500000000000000000000117601325016550400166400ustar00rootroot00000000000000--- :name: zgbbrd :md5sum: 8e300267613885efce454baefeee7dd6 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - q: :type: doublecomplex :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: doublecomplex :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(m,n) - rwork: :type: doublereal :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbcon000077500000000000000000000065471325016550400166570ustar00rootroot00000000000000--- :name: zgbcon :md5sum: 88891109a55972c3b9533da471187b59 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbequ000077500000000000000000000075431325016550400166670ustar00rootroot00000000000000--- :name: zgbequ :md5sum: 96c7688bd118d8f4f184aa7107831370 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - MAX(1,m) - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbequb000077500000000000000000000104061325016550400170210ustar00rootroot00000000000000--- :name: zgbequb :md5sum: cb0bd19ed592f0af1af6e5081b15065e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbrfs000077500000000000000000000127761325016550400166730ustar00rootroot00000000000000--- :name: zgbrfs :md5sum: ff6b0a35d16530b0e7721261123bb43e :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbrfsx000077500000000000000000000427201325016550400170530ustar00rootroot00000000000000--- :name: zgbrfsx :md5sum: c8d8f3dcda58c3e51f64c2c62e669a25 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbsv000077500000000000000000000115031325016550400165140ustar00rootroot00000000000000--- :name: zgbsv :md5sum: ae5d9df6f8b2826acd8be07569b5c355 :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbsvx000077500000000000000000000347111325016550400167120ustar00rootroot00000000000000--- :name: zgbsvx :md5sum: 37f8005219a7ff25ba6532ce78cd340c :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/zgbsvxx000077500000000000000000000564671325016550400171160ustar00rootroot00000000000000--- :name: zgbsvxx :md5sum: 58ec725c8a0af23ab9c7821a70c40cc6 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/zgbtf2000077500000000000000000000074371325016550400165720ustar00rootroot00000000000000--- :name: zgbtf2 :md5sum: 1ccec6ac7bbb39a605e27108190f051d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbtrf000077500000000000000000000074241325016550400166660ustar00rootroot00000000000000--- :name: zgbtrf :md5sum: 6b9ba6577c2423774dbf912b5a5a3595 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgbtrs000077500000000000000000000060401325016550400166740ustar00rootroot00000000000000--- :name: zgbtrs :md5sum: d0b1e4f8ef8e3c1fad70475d295eab0d :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgebak000077500000000000000000000054771325016550400166410ustar00rootroot00000000000000--- :name: zgebak :md5sum: 91449be85cde6d98723559584ca26ef6 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgebal000077500000000000000000000104321325016550400166250ustar00rootroot00000000000000--- :name: zgebal :md5sum: 29bd7a53ad4bc2dbc8daccd7f385fcb5 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgebd2000077500000000000000000000132731325016550400165440ustar00rootroot00000000000000--- :name: zgebd2 :md5sum: a34f063a4eed461697dd095a39a0e253 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublecomplex :intent: output :dims: - MIN(m,n) - taup: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgebrd000077500000000000000000000145721325016550400166470ustar00rootroot00000000000000--- :name: zgebrd :md5sum: faeeaf701bfb70e79e0723c0b655fa1a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublecomplex :intent: output :dims: - MIN(m,n) - taup: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgecon000077500000000000000000000050521325016550400166500ustar00rootroot00000000000000--- :name: zgecon :md5sum: 57c09e654b5c310f1726f52961a7ca80 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeequ000077500000000000000000000065711325016550400166720ustar00rootroot00000000000000--- :name: zgeequ :md5sum: 2b6b705fc741bc84747d85d5d1fa7b5d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeequb000077500000000000000000000074211325016550400170270ustar00rootroot00000000000000--- :name: zgeequb :md5sum: 309542637b4b7d181a093e782883b162 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgees000077500000000000000000000136331325016550400165040ustar00rootroot00000000000000--- :name: zgees :md5sum: 9de99276d77e47de1eb795c27dafa7c3 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: doublecomplex - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: doublecomplex :intent: output :dims: - n - vs: :type: doublecomplex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeesx000077500000000000000000000174601325016550400166760ustar00rootroot00000000000000--- :name: zgeesx :md5sum: c664e00d89738fc39bde317d2585291e :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: doublecomplex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: doublecomplex :intent: output :dims: - n - vs: :type: doublecomplex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: doublereal :intent: output - rcondv: :type: doublereal :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeev000077500000000000000000000115211325016550400165010ustar00rootroot00000000000000--- :name: zgeev :md5sum: a2f45f145f9a86dc68d7611fb89512e0 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeevx000077500000000000000000000231521325016550400166740ustar00rootroot00000000000000--- :name: zgeevx :md5sum: c5b0634690cc9242af9ab759a937a099 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgegs000077500000000000000000000157401325016550400165070ustar00rootroot00000000000000--- :name: zgegs :md5sum: 988d32aa0ef24205bd7a6eaa25b40715 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vsl: :type: doublecomplex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublecomplex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgegv000077500000000000000000000235271325016550400165140ustar00rootroot00000000000000--- :name: zgegv :md5sum: 96caca0b338719751521b432c1b15a00 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgehd2000077500000000000000000000074141325016550400165520ustar00rootroot00000000000000--- :name: zgehd2 :md5sum: 508eab5e25a3d0cf21a0e91f3c9597e0 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - n-1 - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgehrd000077500000000000000000000113431325016550400166460ustar00rootroot00000000000000--- :name: zgehrd :md5sum: 151c13c15d5546777ff58abbdef05187 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgelq2000077500000000000000000000050121325016550400165630ustar00rootroot00000000000000--- :name: zgelq2 :md5sum: 84e06067201c6f460a120e74e1e81915 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgelqf000077500000000000000000000072621325016550400166600ustar00rootroot00000000000000--- :name: zgelqf :md5sum: f67cda2c97b47156b78fc8844b072f73 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgels000077500000000000000000000133061325016550400165100ustar00rootroot00000000000000--- :name: zgels :md5sum: d543f789adef7ad831c7880fbac31097 :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/zgelsd000077500000000000000000000174071325016550400166620ustar00rootroot00000000000000--- :name: zgelsd :md5sum: 3cda6a4e059bdc95d6c1841204c3d144 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "m>=n ? 2*n+n*nrhs : 2*m+m*nrhs" - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - info: :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))) 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)" nlvl: MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0))) smlsiz: ilaenv_(&c__9,"ZGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " 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 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 transformations 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" ruby-lapack-1.8.1/dev/defs/zgelss000077500000000000000000000120241325016550400166670ustar00rootroot00000000000000--- :name: zgelss :md5sum: 3ff0752f7cd079a1daa03043392ba6a3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 5*MIN(m,n) - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/zgelsx000077500000000000000000000123021325016550400166730ustar00rootroot00000000000000--- :name: zgelsx :md5sum: e5aa06fa11b4cff251513549dfaa24c8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgelsy000077500000000000000000000147361325016550400167110ustar00rootroot00000000000000--- :name: zgelsy :md5sum: 0975498361fcf6232bb0bdd055804a74 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 2*n - info: :type: integer :intent: output :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\ *\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" ruby-lapack-1.8.1/dev/defs/zgeql2000077500000000000000000000051631325016550400165720ustar00rootroot00000000000000--- :name: zgeql2 :md5sum: 31856639f92558821325ce108c7eed98 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqlf000077500000000000000000000075011325016550400166540ustar00rootroot00000000000000--- :name: zgeqlf :md5sum: e875061982fc1c96c8778a2ffdf12cc1 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqp3000077500000000000000000000076401325016550400166010ustar00rootroot00000000000000--- :name: zgeqp3 :md5sum: 4e5e3c299fc7580a41a9e5a83aa4402d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n+1 - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqpf000077500000000000000000000067061325016550400166660ustar00rootroot00000000000000--- :name: zgeqpf :md5sum: 51fcf5d185ef9463c8789ce9d0d92782 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqr2000077500000000000000000000047711325016550400166040ustar00rootroot00000000000000--- :name: zgeqr2 :md5sum: b8c457332b3f63fff4aa0e6dd390f3b3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqr2p000077500000000000000000000047741325016550400167670ustar00rootroot00000000000000--- :name: zgeqr2p :md5sum: 91c52296b9bdb3e1d438c64cbffd2d84 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqrf000077500000000000000000000073001325016550400166570ustar00rootroot00000000000000--- :name: zgeqrf :md5sum: fdd67225f3e47265b559a2ec6bf67a18 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgeqrfp000077500000000000000000000073041325016550400170430ustar00rootroot00000000000000--- :name: zgeqrfp :md5sum: 1402e1cace636a626f301ee2f0fbbb65 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgerfs000077500000000000000000000113011325016550400166550ustar00rootroot00000000000000--- :name: zgerfs :md5sum: f648a842e8231bfdf23d4c1045e0c32d :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgerfsx000077500000000000000000000403221325016550400170520ustar00rootroot00000000000000--- :name: zgerfsx :md5sum: 20fccfe77933bc17f97c52905fa7faff :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgerq2000077500000000000000000000052021325016550400165720ustar00rootroot00000000000000--- :name: zgerq2 :md5sum: baea0cbe70a2bf4011f56458fb1c6ba4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgerqf000077500000000000000000000075231325016550400166660ustar00rootroot00000000000000--- :name: zgerqf :md5sum: 7f71fdab4185fb2a41d4eb15cb97fb06 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgesc2000077500000000000000000000045701325016550400165640ustar00rootroot00000000000000--- :name: zgesc2 :md5sum: 7c06097df40e16822688433d8198c64a :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: doublecomplex :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgesdd000077500000000000000000000176041325016550400166510ustar00rootroot00000000000000--- :name: zgesdd :md5sum: 0d191901adb7622e92d1f0b2dc6c8138 :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublecomplex :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: doublecomplex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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)))" - iwork: :type: integer :intent: workspace :dims: - 8*MIN(m,n) - info: :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\") || 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\ *\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" ruby-lapack-1.8.1/dev/defs/zgesv000077500000000000000000000061011325016550400165150ustar00rootroot00000000000000--- :name: zgesv :md5sum: b7f9978f4df659aa04f0e9358fe50f53 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgesvd000077500000000000000000000163041325016550400166670ustar00rootroot00000000000000--- :name: zgesvd :md5sum: 1b2f6212b027d64d169482e5b471fc93 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublecomplex :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: doublecomplex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1, 2*MIN(m,n)+MAX(m,n)) - rwork: :type: doublereal :intent: workspace :dims: - 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 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" ruby-lapack-1.8.1/dev/defs/zgesvx000077500000000000000000000326201325016550400167120ustar00rootroot00000000000000--- :name: zgesvx :md5sum: d529ed3b00b33d4672b39add2d571a25 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :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 :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: output :dims: - 2*n - info: :type: integer :intent: output :substitutions: 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\ *\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 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" ruby-lapack-1.8.1/dev/defs/zgesvxx000077500000000000000000000550371325016550400171110ustar00rootroot00000000000000--- :name: zgesvxx :md5sum: 355fccce5d4132b8483f562355057c26 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/zgetc2000077500000000000000000000050421325016550400165600ustar00rootroot00000000000000--- :name: zgetc2 :md5sum: 017780c8b3ef2a235613004b824db1dc :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgetf2000077500000000000000000000045361325016550400165720ustar00rootroot00000000000000--- :name: zgetf2 :md5sum: 1e1593a51365d9fcf134a0057e1d857d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgetrf000077500000000000000000000045441325016550400166710ustar00rootroot00000000000000--- :name: zgetrf :md5sum: 41f07c12be32d488ebbabd0cf01a2b70 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgetri000077500000000000000000000052321325016550400166670ustar00rootroot00000000000000--- :name: zgetri :md5sum: ae95eea784f2de933d94eed63a3dcc2d :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgetrs000077500000000000000000000047551325016550400167120ustar00rootroot00000000000000--- :name: zgetrs :md5sum: e6b23e55b9e2004e66cec7e32ea11589 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggbak000077500000000000000000000074401325016550400166330ustar00rootroot00000000000000--- :name: zggbak :md5sum: 6989e9096344ffe7d282754d45eeda01 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: doublereal :intent: input :dims: - n - rscale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggbal000077500000000000000000000120101325016550400166210ustar00rootroot00000000000000--- :name: zggbal :md5sum: 2eb576199bbfbe923f6f6bab24ed50f2 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgges000077500000000000000000000214411325016550400165020ustar00rootroot00000000000000--- :name: zgges :md5sum: 910f4c2589adc83dd9ec896220604135 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublecomplex - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vsl: :type: doublecomplex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublecomplex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 8*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggesx000077500000000000000000000266631325016550400167050ustar00rootroot00000000000000--- :name: zggesx :md5sum: d871f51cd6ca4808303ae8fcba8e7fbf :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublecomplex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vsl: :type: doublecomplex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublecomplex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: doublereal :intent: output :dims: - "2" - rcondv: :type: doublereal :intent: output :dims: - "2" - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - 8*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggev000077500000000000000000000150301325016550400165020ustar00rootroot00000000000000--- :name: zggev :md5sum: e16117b677fb268d46e4067d8d0d98ff :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,2*n) - rwork: :type: doublereal :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggevx000077500000000000000000000320661325016550400167020ustar00rootroot00000000000000--- :name: zggevx :md5sum: 4e621547183340b05cd234a1dea49486 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - bbnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - lrwork - iwork: :type: integer :intent: workspace :dims: - "lsame_(&sense,\"E\") ? 0 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" lrwork: "((lsame_(&balanc,\"S\")) || (lsame_(&balanc,\"B\"))) ? MAX(1,6*n) : MAX(1,2*n)" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggglm000077500000000000000000000123441325016550400166540ustar00rootroot00000000000000--- :name: zggglm :md5sum: 4dfcb5e46048a0cc50cbd11d22ab8d4f :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: doublecomplex :intent: input/output :dims: - n - x: :type: doublecomplex :intent: output :dims: - m - y: :type: doublecomplex :intent: output :dims: - p - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgghrd000077500000000000000000000135071325016550400166540ustar00rootroot00000000000000--- :name: zgghrd :md5sum: c4bd0bbb646c8b02ff96b0a6977d8d8c :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgglse000077500000000000000000000122021325016550400166510ustar00rootroot00000000000000--- :name: zgglse :md5sum: 35e6163d310f41393a8f66de172089a5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - m - d: :type: doublecomplex :intent: input/output :dims: - p - x: :type: doublecomplex :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggqrf000077500000000000000000000156251325016550400166720ustar00rootroot00000000000000--- :name: zggqrf :md5sum: c5fa85edaa431364717c95efec26deae :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: doublecomplex :intent: output :dims: - MIN(n,m) - b: :type: doublecomplex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: doublecomplex :intent: output :dims: - MIN(n,p) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggrqf000077500000000000000000000155671325016550400166770ustar00rootroot00000000000000--- :name: zggrqf :md5sum: 585d26f527a6d3aa55af7c50990d406c :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: doublecomplex :intent: output :dims: - MIN(m,n) - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: doublecomplex :intent: output :dims: - MIN(p,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zggsvd000077500000000000000000000246171325016550400166770ustar00rootroot00000000000000--- :name: zggsvd :md5sum: 9dac70b38c11dc008b1cd1e000dc4156 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublecomplex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublecomplex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(3*n,m - p)+n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: 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" :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\ * 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" ruby-lapack-1.8.1/dev/defs/zggsvp000077500000000000000000000155701325016550400167110ustar00rootroot00000000000000--- :name: zggsvp :md5sum: fac9d59192d94c42c95f56a73f97a717 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: doublecomplex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublecomplex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - tau: :type: doublecomplex :intent: workspace :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - MAX(3*n,m - p) - info: :type: integer :intent: output :substitutions: 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" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgtcon000077500000000000000000000065071325016550400166750ustar00rootroot00000000000000--- :name: zgtcon :md5sum: 27adfc903351ec100318405f24932950 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgtrfs000077500000000000000000000131131325016550400166770ustar00rootroot00000000000000--- :name: zgtrfs :md5sum: 8d4d4d8d907eb8ca2c144546d27fcda8 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - dlf: :type: doublecomplex :intent: input :dims: - n-1 - df: :type: doublecomplex :intent: input :dims: - n - duf: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgtsv000077500000000000000000000056571325016550400165530ustar00rootroot00000000000000--- :name: zgtsv :md5sum: 6f8eba9f6419e66310194d8c7a7cce23 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input/output :dims: - n-1 - d: :type: doublecomplex :intent: input/output :dims: - n - du: :type: doublecomplex :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgtsvx000077500000000000000000000235451325016550400167370ustar00rootroot00000000000000--- :name: zgtsvx :md5sum: 898a2cdb954f54175f3ed1880fdf619e :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - dlf: :type: doublecomplex :intent: input/output :dims: - n-1 - df: :type: doublecomplex :intent: input/output :dims: - n - duf: :type: doublecomplex :intent: input/output :dims: - n-1 - du2: :type: doublecomplex :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgttrf000077500000000000000000000061371325016550400167100ustar00rootroot00000000000000--- :name: zgttrf :md5sum: 66195e75eb1a5199cd58d87b31de3919 :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: doublecomplex :intent: input/output :dims: - n-1 - d: :type: doublecomplex :intent: input/output :dims: - n - du: :type: doublecomplex :intent: input/output :dims: - n-1 - du2: :type: doublecomplex :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgttrs000077500000000000000000000070441325016550400167230ustar00rootroot00000000000000--- :name: zgttrs :md5sum: 0ca17e08872927fc933bf9e16738ea54 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zgtts2000077500000000000000000000061561325016550400166260ustar00rootroot00000000000000--- :name: zgtts2 :md5sum: 162d28e29ce7ddeac4dd6a28f9dfc718 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbev000077500000000000000000000076551325016550400165140ustar00rootroot00000000000000--- :name: zhbev :md5sum: 4aa6337b1416770872716376ca785458 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbevd000077500000000000000000000164531325016550400166540ustar00rootroot00000000000000--- :name: zhbevd :md5sum: 106aa15cb26a281f9d3f65ba8715cae8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbevx000077500000000000000000000200201325016550400166610ustar00rootroot00000000000000--- :name: zhbevx :md5sum: 8110f15a075adb5e9c09fc8ccc5ca0f5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbgst000077500000000000000000000101351325016550400166620ustar00rootroot00000000000000--- :name: zhbgst :md5sum: b25f0a732a0eebdab26f937666828130 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbgv000077500000000000000000000131221325016550400165000ustar00rootroot00000000000000--- :name: zhbgv :md5sum: 53ed0c8a2fa947bd3a711b8a8c2025f0 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbgvd000077500000000000000000000210761325016550400166530ustar00rootroot00000000000000--- :name: zhbgvd :md5sum: e3c34343db6714b14c8e3b65e7cbccf2 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhbgvx000077500000000000000000000220431325016550400166720ustar00rootroot00000000000000--- :name: zhbgvx :md5sum: 76d1dc537517a9baeb413baa3e8601b5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" 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\ *\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" ruby-lapack-1.8.1/dev/defs/zhbtrd000077500000000000000000000101351325016550400166560ustar00rootroot00000000000000--- :name: zhbtrd :md5sum: b006b2fa43cf22296aff342b25156c72 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhecon000077500000000000000000000052441325016550400166540ustar00rootroot00000000000000--- :name: zhecon :md5sum: a7a7115b4ebb274e00fbe09d609df27c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zheequb000077500000000000000000000052211325016550400170240ustar00rootroot00000000000000--- :name: zheequb :md5sum: 7b6794b81f1747a915e16b94b240d5e3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zheev000077500000000000000000000071141325016550400165050ustar00rootroot00000000000000--- :name: zheev :md5sum: d20b733ac955437780c0f0f4ad96dad9 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zheevd000077500000000000000000000155371325016550400166610ustar00rootroot00000000000000--- :name: zheevd :md5sum: cfb4c97c52c4714d3a44874ba9810d89 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zheevr000077500000000000000000000321611325016550400166670ustar00rootroot00000000000000--- :name: zheevr :md5sum: f47d50a9af6c562dfda0198807baa560 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 24*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zheevx000077500000000000000000000177661325016550400167130ustar00rootroot00000000000000--- :name: zheevx :md5sum: 58d3330be7b1e45e72df64fff77eb075 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 2*n" - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhegs2000077500000000000000000000057641325016550400165770ustar00rootroot00000000000000--- :name: zhegs2 :md5sum: 807744acbc0fa9344d5087a32c297268 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhegst000077500000000000000000000057611325016550400166760ustar00rootroot00000000000000--- :name: zhegst :md5sum: c20dbdb32438b9794fb86eb0c5c5348d :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhegv000077500000000000000000000127121325016550400165070ustar00rootroot00000000000000--- :name: zhegv :md5sum: 07c9d92c53a06b1456cf9411ad416814 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhegvd000077500000000000000000000214031325016550400166500ustar00rootroot00000000000000--- :name: zhegvd :md5sum: c08fb41eb03abb64ff3169f9ef5e7f3d :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhegvx000077500000000000000000000235131325016550400167000ustar00rootroot00000000000000--- :name: zhegvx :md5sum: 7003398fac9b579afd4a69d0f774a610 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zherfs000077500000000000000000000123131325016550400166620ustar00rootroot00000000000000--- :name: zherfs :md5sum: 5526aebb74609c66f4e00e60fd27abae :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zherfsx000077500000000000000000000376141325016550400170650ustar00rootroot00000000000000--- :name: zherfsx :md5sum: c5087f3ef812132fa16bb2e388fa2bc3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhesv000077500000000000000000000127321325016550400165250ustar00rootroot00000000000000--- :name: zhesv :md5sum: e745a4fbd2863ca527128103dc22130f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhesvx000077500000000000000000000235661325016550400167240ustar00rootroot00000000000000--- :name: zhesvx :md5sum: d32755a1d0cd2467834e0bb251f252c1 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhesvxx000077500000000000000000000513371325016550400171110ustar00rootroot00000000000000--- :name: zhesvxx :md5sum: d41a02cad371c27e3d0b19c85d52f180 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/zhetd2000077500000000000000000000116511325016550400165650ustar00rootroot00000000000000--- :name: zhetd2 :md5sum: 5d6c063c7692d78bc773c0606e59e8a0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhetf2000077500000000000000000000131071325016550400165650ustar00rootroot00000000000000--- :name: zhetf2 :md5sum: 725e5436827d63711e21fdeffc5c30d6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhetrd000077500000000000000000000131701325016550400166630ustar00rootroot00000000000000--- :name: zhetrd :md5sum: 8ff61910f96d3aa218cab2a83ffadca4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhetrf000077500000000000000000000140321325016550400166630ustar00rootroot00000000000000--- :name: zhetrf :md5sum: 270922db5c4465a08b91b72e143e19ff :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhetri000077500000000000000000000050771325016550400166770ustar00rootroot00000000000000--- :name: zhetri :md5sum: e2b7ed70acb2f49352be473cb1de436e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhetrs000077500000000000000000000050101325016550400166740ustar00rootroot00000000000000--- :name: zhetrs :md5sum: 23eb0d09ccb9891c4e2ae7e710b35ca6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhetrs2000077500000000000000000000052611325016550400167660ustar00rootroot00000000000000--- :name: zhetrs2 :md5sum: ccc24e2bde3f20ad75f420ff6ebeee26 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhfrk000077500000000000000000000107041325016550400165070ustar00rootroot00000000000000--- :name: zhfrk :md5sum: f710d76bdfec0a51ef55bb6978763909 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - "lsame_(&trans,\"N\") ? k : n" - lda: :type: integer :intent: input - beta: :type: doublereal :intent: input - c: :type: doublecomplex :intent: input/output :dims: - 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\ *\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" ruby-lapack-1.8.1/dev/defs/zhgeqz000077500000000000000000000224621325016550400166770ustar00rootroot00000000000000--- :name: zhgeqz :md5sum: abe28a9dc3cbffd9489f94d78eb0d905 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpcon000077500000000000000000000051031325016550400166610ustar00rootroot00000000000000--- :name: zhpcon :md5sum: f06328a28b5679c1819985fa02dc711a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpev000077500000000000000000000070511325016550400165200ustar00rootroot00000000000000--- :name: zhpev :md5sum: 29948d79784f28856fc93f9c14691050 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpevd000077500000000000000000000156051325016550400166700ustar00rootroot00000000000000--- :name: zhpevd :md5sum: 6547972d4a8ed778f40a7ad0af3719f2 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpevx000077500000000000000000000164431325016550400167150ustar00rootroot00000000000000--- :name: zhpevx :md5sum: 6bf75070a769cbabc0a9a3b578487f43 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpgst000077500000000000000000000051341325016550400167030ustar00rootroot00000000000000--- :name: zhpgst :md5sum: a1803b2aef0acbf9361949b4fa807afd :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - bp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpgv000077500000000000000000000122331325016550400165200ustar00rootroot00000000000000--- :name: zhpgv :md5sum: e5c6764a97b39058ee96f9390c29cdc2 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - bp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpgvd000077500000000000000000000211361325016550400166660ustar00rootroot00000000000000--- :name: zhpgvd :md5sum: e81d6e43ac0f0338388ac1726dcfa821 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - bp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpgvx000077500000000000000000000222501325016550400167100ustar00rootroot00000000000000--- :name: zhpgvx :md5sum: 7fe4092d2b27387168e9fe2e853c469e :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - bp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhprfs000077500000000000000000000115051325016550400166770ustar00rootroot00000000000000--- :name: zhprfs :md5sum: 363a2f0473501f9de1cea18f56f0d6ba :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpsv000077500000000000000000000115621325016550400165400ustar00rootroot00000000000000--- :name: zhpsv :md5sum: 0713716e5e44cdc4522b3e60e4cd557d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhpsvx000077500000000000000000000227011325016550400167250ustar00rootroot00000000000000--- :name: zhpsvx :md5sum: 1b089b8de3c3c23cb14a6227f6eccf46 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhptrd000077500000000000000000000077451325016550400167110ustar00rootroot00000000000000--- :name: zhptrd :md5sum: 9d8dcc90a6a09c895332ed4d3bafa8f9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhptrf000077500000000000000000000115371325016550400167050ustar00rootroot00000000000000--- :name: zhptrf :md5sum: a5f6c770830276234c0c42f2e5e0d35f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhptri000077500000000000000000000047331325016550400167100ustar00rootroot00000000000000--- :name: zhptri :md5sum: 9a9ff958ef312371ebb95295f2bf585d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhptrs000077500000000000000000000046671325016550400167300ustar00rootroot00000000000000--- :name: zhptrs :md5sum: 6d68e7a4b40ea6491c12717a153266a3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhsein000077500000000000000000000167321325016550400166720ustar00rootroot00000000000000--- :name: zhsein :md5sum: e2281999ac422c1eb5a43a6ce31f629e :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - h: :type: doublecomplex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: input/output :dims: - n - vl: :type: doublecomplex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - n*n - rwork: :type: doublereal :intent: workspace :dims: - n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zhseqr000077500000000000000000000263401325016550400167020ustar00rootroot00000000000000--- :name: zhseqr :md5sum: ef6b85e6bdbf0fa44c0c2503d7c14f6f :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - z: :type: doublecomplex :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gbamv000077500000000000000000000121431325016550400173240ustar00rootroot00000000000000--- :name: zla_gbamv :md5sum: 9e790ed0e59a002f6667b528896bf632 :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: doublereal :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: ldab: MAX(1, m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gbrcond_c000077500000000000000000000107051325016550400201520ustar00rootroot00000000000000--- :name: zla_gbrcond_c :md5sum: 1dcbea81eec20033235e6bc8b3fbb4c5 :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gbrcond_x000077500000000000000000000104121325016550400201720ustar00rootroot00000000000000--- :name: zla_gbrcond_x :md5sum: 82710e74ceba14453857104a1281a7b2 :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gbrfsx_extended000077500000000000000000000362721325016550400214140ustar00rootroot00000000000000--- :name: zla_gbrfsx_extended :md5sum: 583c722c3f706254fb3dd1f1bdb61bf9 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/zla_gbrpvgrw000077500000000000000000000060541325016550400200740ustar00rootroot00000000000000--- :name: zla_gbrpvgrw :md5sum: 93b4b0e0e44371aacf2dcc4f944acec7 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_geamv000077500000000000000000000114111325016550400173240ustar00rootroot00000000000000--- :name: zla_geamv :md5sum: ee793a4d70e846cfb17334848e117602 :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: lda: MAX(1, m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gercond_c000077500000000000000000000073321325016550400201570ustar00rootroot00000000000000--- :name: zla_gercond_c :md5sum: 2e3c096c2d951fe9fae9aeba664dc25f :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gercond_x000077500000000000000000000070711325016550400202040ustar00rootroot00000000000000--- :name: zla_gercond_x :md5sum: 1e10515b8db3cc06a4a3a28106b51f3f :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_gerfsx_extended000077500000000000000000000354561325016550400214220ustar00rootroot00000000000000--- :name: zla_gerfsx_extended :md5sum: 85446eaf381da203f656d20ee1d661d6 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - errs_n: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - errs_c: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n_norms: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_heamv000077500000000000000000000112241325016550400173270ustar00rootroot00000000000000--- :name: zla_heamv :md5sum: 70eb4515737b3a9e54d3e6092582824a :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + (n-1)*abs(incx) - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: MAX(1, n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_hercond_c000077500000000000000000000070601325016550400201560ustar00rootroot00000000000000--- :name: zla_hercond_c :md5sum: bbcd580ed7550b8d9f2ce9d894f56ec1 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_hercond_x000077500000000000000000000065641325016550400202130ustar00rootroot00000000000000--- :name: zla_hercond_x :md5sum: ccd25c75038fb2a611096e4c99c03ee3 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_herfsx_extended000077500000000000000000000352421325016550400214140ustar00rootroot00000000000000--- :name: zla_herfsx_extended :md5sum: 99391e842a46fddd9ee369da7d076db8 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_herpvgrw000077500000000000000000000063041325016550400200760ustar00rootroot00000000000000--- :name: zla_herpvgrw :md5sum: c7a4c2c50b491711138d57d30bf2f509 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_lin_berr000077500000000000000000000052441325016550400200300ustar00rootroot00000000000000--- :name: zla_lin_berr :md5sum: 47f37ceeda0e82d8850d983f22cb3407 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: doublereal :intent: input :dims: - n - nrhs - ayb: :type: doublereal :intent: input :dims: - n - nrhs - berr: :type: doublecomplex :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_porcond_c000077500000000000000000000065511325016550400202040ustar00rootroot00000000000000--- :name: zla_porcond_c :md5sum: 7f972d94051304574e069015710f2e69 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_porcond_x000077500000000000000000000062271325016550400202310ustar00rootroot00000000000000--- :name: zla_porcond_x :md5sum: 0fa4ca3979f7fa847286e416f8ffbeda :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_porfsx_extended000077500000000000000000000346731325016550400214450ustar00rootroot00000000000000--- :name: zla_porfsx_extended :md5sum: b1329c654babe3970201a34d324770a2 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_porpvgrw000077500000000000000000000052221325016550400201160ustar00rootroot00000000000000--- :name: zla_porpvgrw :md5sum: e917efebc5e4c9397b6b5953515fb481 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: doublecomplex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_rpvgrw000077500000000000000000000044611325016550400175630ustar00rootroot00000000000000--- :name: zla_rpvgrw :md5sum: 973297576068c8104e05e11efcbf080f :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_syamv000077500000000000000000000112221325016550400173640ustar00rootroot00000000000000--- :name: zla_syamv :md5sum: 041a90dddeca6e2506af8fce8e2257a1 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: MAX(1, n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_syrcond_c000077500000000000000000000071061325016550400202160ustar00rootroot00000000000000--- :name: zla_syrcond_c :md5sum: dc1bde7c84b5aa69b54885640a0c0150 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_syrcond_x000077500000000000000000000066171325016550400202510ustar00rootroot00000000000000--- :name: zla_syrcond_x :md5sum: 2ee84b2298e93cd97cc2b1f8137a5f05 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_syrfsx_extended000077500000000000000000000352421325016550400214530ustar00rootroot00000000000000--- :name: zla_syrfsx_extended :md5sum: 1bbc80dff104ad9433d7b76fc0d7da02 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_syrpvgrw000077500000000000000000000063371325016550400201430ustar00rootroot00000000000000--- :name: zla_syrpvgrw :md5sum: 317835fcbf8ec3e2105e90ebf3c36c72 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zla_wwaddw000077500000000000000000000026411325016550400175270ustar00rootroot00000000000000--- :name: zla_wwaddw :md5sum: e64523786b99132b6bdedbd2c060e7e5 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - n - y: :type: doublecomplex :intent: input/output :dims: - n - w: :type: doublecomplex :intent: input :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlabrd000077500000000000000000000147121325016550400166440ustar00rootroot00000000000000--- :name: zlabrd :md5sum: 162a9368de85a7bfb4b6ba8b9e25a27f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MAX(1,nb) - e: :type: doublereal :intent: output :dims: - MAX(1,nb) - tauq: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - taup: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - x: :type: doublecomplex :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: doublecomplex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: MAX(1,m) ldy: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacgv000077500000000000000000000022461325016550400166530ustar00rootroot00000000000000--- :name: zlacgv :md5sum: 062160ffd42244a74a662d0cb3c52b28 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacn2000077500000000000000000000056221325016550400165570ustar00rootroot00000000000000--- :name: zlacn2 :md5sum: d0aba13d98ac5036c2909c711b5db9b7 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublecomplex :intent: workspace :dims: - n - x: :type: doublecomplex :intent: input/output :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacon000077500000000000000000000046561325016550400166620ustar00rootroot00000000000000--- :name: zlacon :md5sum: da79628afbd39cf73c8240528208f1d5 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublecomplex :intent: workspace :dims: - n - x: :type: doublecomplex :intent: input/output :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacp2000077500000000000000000000042361325016550400165610ustar00rootroot00000000000000--- :name: zlacp2 :md5sum: 4c1a1c73163c0973ae7dd46cbc5aaa20 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacpy000077500000000000000000000042241325016550400166650ustar00rootroot00000000000000--- :name: zlacpy :md5sum: 1484db6d74eb437e2eeddcb1bcbca9ef :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacrm000077500000000000000000000042341325016550400166540ustar00rootroot00000000000000--- :name: zlacrm :md5sum: 9ae33084c6b14c9ddd1a66b99572017a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlacrt000077500000000000000000000036131325016550400166630ustar00rootroot00000000000000--- :name: zlacrt :md5sum: 604f79f577cce40b1cf8d8abaa65ee99 :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: doublecomplex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: doublecomplex :intent: input - s: :type: doublecomplex :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zladiv000077500000000000000000000020041325016550400166460ustar00rootroot00000000000000--- :name: zladiv :md5sum: 77ac55670f709d4b3ebd8a87ee08a32a :category: :function :type: doublecomplex :arguments: - x: :type: doublecomplex :intent: input - y: :type: doublecomplex :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaed0000077500000000000000000000074551325016550400165530ustar00rootroot00000000000000--- :name: zlaed0 :md5sum: 0fc362ce3bc169eeb9caad18edabb44d :category: :subroutine :arguments: - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: doublecomplex :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - 1 + 3*n + 2*n*LG(n) + 3*pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 6 + 6*n + 5*n*LG(n) - info: :type: integer :intent: output :substitutions: ldqs: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaed7000077500000000000000000000176151325016550400165610ustar00rootroot00000000000000--- :name: zlaed7 :md5sum: d4f753104c3d1ea76346b6c9c300455a :category: :subroutine :arguments: - n: :type: integer :intent: input - cutpnt: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: doublereal :intent: input - indxq: :type: integer :intent: output :dims: - n - qstore: :type: doublereal :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: doublereal :intent: input :dims: - "2" - n*LG(n) - work: :type: doublecomplex :intent: workspace :dims: - qsiz*n - rwork: :type: doublereal :intent: workspace :dims: - 3*n+2*qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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 occurrence 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" ruby-lapack-1.8.1/dev/defs/zlaed8000077500000000000000000000154311325016550400165540ustar00rootroot00000000000000--- :name: zlaed8 :md5sum: da94804bd8bee4c6a24adacd2c1c9816 :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - rho: :type: doublereal :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - n - dlamda: :type: doublereal :intent: output :dims: - n - q2: :type: doublecomplex :intent: output :dims: - ldq2 - n - ldq2: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - indxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: doublereal :intent: output :dims: - "2" - n - info: :type: integer :intent: output :substitutions: ldq2: MAX( 1, n ) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaein000077500000000000000000000064101325016550400166440ustar00rootroot00000000000000--- :name: zlaein :md5sum: 845486ba7c6cdc14509c94e425271687 :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: doublecomplex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: input - v: :type: doublecomplex :intent: input/output :dims: - n - b: :type: doublecomplex :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - n - eps3: :type: doublereal :intent: input - smlnum: :type: doublereal :intent: input - info: :type: integer :intent: output :substitutions: ldb: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaesy000077500000000000000000000050441325016550400166730ustar00rootroot00000000000000--- :name: zlaesy :md5sum: 642ca3d28da008080be23ca24f63fa2c :category: :subroutine :arguments: - a: :type: doublecomplex :intent: input - b: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input - rt1: :type: doublecomplex :intent: output - rt2: :type: doublecomplex :intent: output - evscal: :type: doublecomplex :intent: output - cs1: :type: doublecomplex :intent: output - sn1: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaev2000077500000000000000000000050251325016550400165660ustar00rootroot00000000000000--- :name: zlaev2 :md5sum: 49df9aa5c2dd69b5dc367d52878c9391 :category: :subroutine :arguments: - a: :type: doublecomplex :intent: input - b: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input - rt1: :type: doublereal :intent: output - rt2: :type: doublereal :intent: output - cs1: :type: doublereal :intent: output - sn1: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlag2c000077500000000000000000000045461325016550400165540ustar00rootroot00000000000000--- :name: zlag2c :md5sum: 74fe0ffefcc616f52a172abaa7fccf0d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: complex :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,m) :fortran_help: " 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 conversion 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" ruby-lapack-1.8.1/dev/defs/zlags2000077500000000000000000000065241325016550400165720ustar00rootroot00000000000000--- :name: zlags2 :md5sum: 3e5b9ee0cacaa512ab8a822358e62805 :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: doublereal :intent: input - a2: :type: doublecomplex :intent: input - a3: :type: doublereal :intent: input - b1: :type: doublereal :intent: input - b2: :type: doublecomplex :intent: input - b3: :type: doublereal :intent: input - csu: :type: doublereal :intent: output - snu: :type: doublecomplex :intent: output - csv: :type: doublereal :intent: output - snv: :type: doublecomplex :intent: output - csq: :type: doublereal :intent: output - snq: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlagtm000077500000000000000000000062021325016550400166570ustar00rootroot00000000000000--- :name: zlagtm :md5sum: 7cbf078fe6ef87658cc59e02f706c853 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: doublereal :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: doublereal :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlahef000077500000000000000000000106761325016550400166440ustar00rootroot00000000000000--- :name: zlahef :md5sum: 43bf4f4327aedf5ca806b99215ebff6b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: doublecomplex :intent: workspace :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlahqr000077500000000000000000000134161325016550400166670ustar00rootroot00000000000000--- :name: zlahqr :md5sum: 94def9c763c6ce11a5fa6e92f7c284a6 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlahr2000077500000000000000000000116221325016550400165650ustar00rootroot00000000000000--- :name: zlahr2 :md5sum: 9ac30357bebcece7da5d61625afa8bb7 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - t: :type: doublecomplex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublecomplex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlahrd000077500000000000000000000106121325016550400166450ustar00rootroot00000000000000--- :name: zlahrd :md5sum: a88d81f8a9f0ae03b94abf04574ebfc7 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - t: :type: doublecomplex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublecomplex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: MAX(1,n) ldt: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaic1000077500000000000000000000053421325016550400165500ustar00rootroot00000000000000--- :name: zlaic1 :md5sum: 63910da00daf76915c35466d47fea244 :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - j - sest: :type: doublereal :intent: input - w: :type: doublecomplex :intent: input :dims: - j - gamma: :type: doublecomplex :intent: input - sestpr: :type: doublereal :intent: output - s: :type: doublecomplex :intent: output - c: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlals0000077500000000000000000000171351325016550400165750ustar00rootroot00000000000000--- :name: zlals0 :md5sum: 6c3f08f2e87225b43e82d00fc4312c59 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublecomplex :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: doublereal :intent: input :dims: - ldgnum - "2" - difl: :type: doublereal :intent: input :dims: - k - difr: :type: doublereal :intent: input :dims: - ldgnum - "2" - z: :type: doublereal :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: doublereal :intent: input - s: :type: doublereal :intent: input - rwork: :type: doublereal :intent: workspace :dims: - k*(1+nrhs) + 2*nrhs - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlalsa000077500000000000000000000200211325016550400166420ustar00rootroot00000000000000--- :name: zlalsa :md5sum: dd9ab43ee14de96210fce94d8fd0fbe9 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublecomplex :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: doublereal :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: doublereal :intent: input :dims: - ldu - nlvl - difr: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - z: :type: doublereal :intent: input :dims: - ldu - nlvl - poles: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - c: :type: doublereal :intent: input :dims: - n - s: :type: doublereal :intent: input :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - MAX(n,(smlsiz+1)*nrhs*3) - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlalsd000077500000000000000000000127161325016550400166610ustar00rootroot00000000000000--- :name: zlalsd :md5sum: 67b57ad9803fd57023c3c14223c42c05 :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - n * nrhs - rwork: :type: doublereal :intent: workspace :dims: - 9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlangb000077500000000000000000000055271325016550400166470ustar00rootroot00000000000000--- :name: zlangb :md5sum: 4120e61255d0848a64b6de95b2ceac7d :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "MAX(1,lsame_(&norm,\"I\") ? n : 0)" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlange000077500000000000000000000047501325016550400166470ustar00rootroot00000000000000--- :name: zlange :md5sum: 50408df6803944fddcccdb05db912293 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlangt000077500000000000000000000043121325016550400166600ustar00rootroot00000000000000--- :name: zlangt :md5sum: 9e28b2c5225e24d990e7ee9a95247313 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlanhb000077500000000000000000000064461325016550400166510ustar00rootroot00000000000000--- :name: zlanhb :md5sum: 5c87108609a1d4de7b166f8a854c225e :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlanhe000077500000000000000000000063421325016550400166470ustar00rootroot00000000000000--- :name: zlanhe :md5sum: 1b2b837bfeae7c4b9e9012d4e8676435 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlanhf000077500000000000000000000200751325016550400166470ustar00rootroot00000000000000--- :name: zlanhf :md5sum: 70d3555cf9335d87bbaccab9490116b5 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - lwork :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlanhp000077500000000000000000000057241325016550400166650ustar00rootroot00000000000000--- :name: zlanhp :md5sum: 5e520aeb2ec37a3f0f87b0a8b7b4df17 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlanhs000077500000000000000000000045671325016550400166740ustar00rootroot00000000000000--- :name: zlanhs :md5sum: 0d7a937484d67bc8e510f66da14bec2f :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlanht000077500000000000000000000040411325016550400166600ustar00rootroot00000000000000--- :name: zlanht :md5sum: 6a22c58b6e99c06f31961f03100c6c14 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlansb000077500000000000000000000063051325016550400166560ustar00rootroot00000000000000--- :name: zlansb :md5sum: 2cf3136063091d0832acc52777370cbe :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlansp000077500000000000000000000055201325016550400166720ustar00rootroot00000000000000--- :name: zlansp :md5sum: b3032545d19330061f35960b61a3e82e :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlansy000077500000000000000000000061571325016550400167120ustar00rootroot00000000000000--- :name: zlansy :md5sum: 53d4b9c917535a23b36d076e4b5e3c08 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlantb000077500000000000000000000071231325016550400166560ustar00rootroot00000000000000--- :name: zlantb :md5sum: b83aebd51718807ea87f8fe975fb3cb7 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlantp000077500000000000000000000061771325016550400167040ustar00rootroot00000000000000--- :name: zlantp :md5sum: 5643fadc8657c6b20518835ef43210f4 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlantr000077500000000000000000000073211325016550400166760ustar00rootroot00000000000000--- :name: zlantr :md5sum: 9d1a08cb51c9b20cc3eee17c6a416266 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlapll000077500000000000000000000036151325016550400166640ustar00rootroot00000000000000--- :name: zlapll :md5sum: f38274c6caef49904c71c30719914830 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: doublereal :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlapmr000077500000000000000000000040221325016550400166640ustar00rootroot00000000000000--- :name: zlapmr :md5sum: 1282557fcda59064b1199667798f0e85 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlapmt000077500000000000000000000040251325016550400166710ustar00rootroot00000000000000--- :name: zlapmt :md5sum: 591f8631e725fd98463952019c2571aa :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqgb000077500000000000000000000074621325016550400166520ustar00rootroot00000000000000--- :name: zlaqgb :md5sum: 2b4f33f517dd2fd23e7047fd285f0a66 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqge000077500000000000000000000062661325016550400166560ustar00rootroot00000000000000--- :name: zlaqge :md5sum: e14f9153c59e94be579139041a5cbd9f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqhb000077500000000000000000000064601325016550400166500ustar00rootroot00000000000000--- :name: zlaqhb :md5sum: 93d6db03126ffc6978f3941fef25ee6c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqhe000077500000000000000000000060511325016550400166470ustar00rootroot00000000000000--- :name: zlaqhe :md5sum: 77e6b178f95bcb2b254421aa82d4d8cd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqhp000077500000000000000000000054161325016550400166660ustar00rootroot00000000000000--- :name: zlaqhp :md5sum: 4b5255af747ad03a9813eafa66d1d2da :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqp2000077500000000000000000000067461325016550400166070ustar00rootroot00000000000000--- :name: zlaqp2 :md5sum: 43aa720c87c5cf4c98fa3414b977cce5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqps000077500000000000000000000076541325016550400167070ustar00rootroot00000000000000--- :name: zlaqps :md5sum: a668f9d3c711ffd359dd258d703585bb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - kb - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - auxv: :type: doublecomplex :intent: input/output :dims: - nb - f: :type: doublecomplex :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqr0000077500000000000000000000174631325016550400166050ustar00rootroot00000000000000--- :name: zlaqr0 :md5sum: b1ca48722dced304d23bdf7ff40fa5fd :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihi : 0" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqr1000077500000000000000000000035641325016550400166030ustar00rootroot00000000000000--- :name: zlaqr1 :md5sum: dc7298366a69e9aa5a46ad5c668db6b1 :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: doublecomplex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - s1: :type: doublecomplex :intent: input - s2: :type: doublecomplex :intent: input - v: :type: doublecomplex :intent: output :dims: - n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqr2000077500000000000000000000200221325016550400165700ustar00rootroot00000000000000--- :name: zlaqr2 :md5sum: ffeac35e8baa8da04e2b19326ee08e26 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: doublecomplex :intent: output :dims: - MAX(1,kbot) - v: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqr3000077500000000000000000000174641325016550400166110ustar00rootroot00000000000000--- :name: zlaqr3 :md5sum: 278a48c359e34540731d6e298ce7c331 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: doublecomplex :intent: output :dims: - MAX(1,kbot) - v: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqr4000077500000000000000000000174651325016550400166130ustar00rootroot00000000000000--- :name: zlaqr4 :md5sum: a1ca2c176247952b0c88578286a3070f :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: ldz: "wantz ? MAX(1,ihiz) : 1" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqr5000077500000000000000000000162701325016550400166050ustar00rootroot00000000000000--- :name: zlaqr5 :md5sum: de74b49e2130ffd48980da890514c237 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - s: :type: doublecomplex :intent: input/output :dims: - nshfts - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: doublecomplex :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: doublecomplex :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublecomplex :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: doublecomplex :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqsb000077500000000000000000000064561325016550400166700ustar00rootroot00000000000000--- :name: zlaqsb :md5sum: 29dea065db6a95e6e3f4254e406dc67e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqsp000077500000000000000000000054161325016550400167010ustar00rootroot00000000000000--- :name: zlaqsp :md5sum: 515183f69fcd0fff72e408ac43741f2e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaqsy000077500000000000000000000060511325016550400167060ustar00rootroot00000000000000--- :name: zlaqsy :md5sum: 33fa22407b763579d1adde067c2b0d27 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlar1v000077500000000000000000000146321325016550400166060ustar00rootroot00000000000000--- :name: zlar1v :md5sum: fc48ffc43e478939142fe3cbe328113b :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - l: :type: doublereal :intent: input :dims: - n-1 - ld: :type: doublereal :intent: input :dims: - n-1 - lld: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - gaptol: :type: doublereal :intent: input - z: :type: doublecomplex :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: doublereal :intent: output - mingma: :type: doublereal :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: doublereal :intent: output - resid: :type: doublereal :intent: output - rqcorr: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlar2v000077500000000000000000000052441325016550400166060ustar00rootroot00000000000000--- :name: zlar2v :md5sum: e546278eb7b619c19afba3766521f824 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - z: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublecomplex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarcm000077500000000000000000000042421325016550400166530ustar00rootroot00000000000000--- :name: zlarcm :md5sum: 56086b8d732437efd20f5eb5f4efa2ea :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,m) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarf000077500000000000000000000052141325016550400165010ustar00rootroot00000000000000--- :name: zlarf :md5sum: f12ff196863e7cc551d26a0f1f27dd12 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarfb000077500000000000000000000077021325016550400166470ustar00rootroot00000000000000--- :name: zlarfb :md5sum: 627c934444abbc66d8956c26ce0a6217 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: doublecomplex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/zlarfg000077500000000000000000000040041325016550400166440ustar00rootroot00000000000000--- :name: zlarfg :md5sum: ce36054c7cc3734a13a0cfaf1fa30a13 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input/output - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarfgp000077500000000000000000000037211325016550400170310ustar00rootroot00000000000000--- :name: zlarfgp :md5sum: 8380298bf6ea2a06c5eba285dbcf2805 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input/output - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarft000077500000000000000000000107571325016550400166750ustar00rootroot00000000000000--- :name: zlarft :md5sum: e49ec2f4472e3bae691c01b3a570c0e5 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - t: :type: doublecomplex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarfx000077500000000000000000000046401325016550400166730ustar00rootroot00000000000000--- :name: zlarfx :md5sum: 2b9a75e56e7da3bbfc63c5b8030bda4d :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - m - tau: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlargv000077500000000000000000000050541325016550400166720ustar00rootroot00000000000000--- :name: zlargv :md5sum: bc7733bbe1d5c4b2c02183f807aadd34 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarnv000077500000000000000000000037211325016550400167000ustar00rootroot00000000000000--- :name: zlarnv :md5sum: 36e5ab2161ffb5a09faacf3c756eed1b :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarrv000077500000000000000000000222661325016550400167110ustar00rootroot00000000000000--- :name: zlarrv :md5sum: ae9ce24a0dd6a243053bd6396969a553 :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - d: :type: doublereal :intent: input/output :dims: - n - l: :type: doublereal :intent: input/output :dims: - n - pivmin: :type: doublereal :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: doublereal :intent: input - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - w: :type: doublereal :intent: input/output :dims: - n - werr: :type: doublereal :intent: input/output :dims: - n - wgap: :type: doublereal :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: doublereal :intent: input :dims: - 2*n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " 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 split.) 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 occurred 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" ruby-lapack-1.8.1/dev/defs/zlarscl2000077500000000000000000000030621325016550400171160ustar00rootroot00000000000000--- :name: zlarscl2 :md5sum: 080c93b0555c1909ea0298bd0d4ec2f9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlartg000077500000000000000000000035151325016550400166700ustar00rootroot00000000000000--- :name: zlartg :md5sum: 669790d67331c2cd17991b7c96ecc53d :category: :subroutine :arguments: - f: :type: doublecomplex :intent: input - g: :type: doublecomplex :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublecomplex :intent: output - r: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlartv000077500000000000000000000043131325016550400167040ustar00rootroot00000000000000--- :name: zlartv :md5sum: e5ca2c7119fc89e868f72f604550a7d4 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublecomplex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarz000077500000000000000000000061221325016550400165240ustar00rootroot00000000000000--- :name: zlarz :md5sum: 51817751cd08b24f60b8544807b10bea :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlarzb000077500000000000000000000103661325016550400166730ustar00rootroot00000000000000--- :name: zlarzb :md5sum: c84f4faa09b773e85cce145ad0d50edf :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: doublecomplex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: 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\ *\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" ruby-lapack-1.8.1/dev/defs/zlarzt000077500000000000000000000123071325016550400167120ustar00rootroot00000000000000--- :name: zlarzt :md5sum: 10bdb46591b0abb303255f8db76e37b7 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - t: :type: doublecomplex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlascl000077500000000000000000000064031325016550400166540ustar00rootroot00000000000000--- :name: zlascl :md5sum: bebaac4c17a950c4466313a4484f3dac :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: doublereal :intent: input - cto: :type: doublereal :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlascl2000077500000000000000000000030361325016550400167350ustar00rootroot00000000000000--- :name: zlascl2 :md5sum: 429cf4142645802480d42330910b72d1 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaset000077500000000000000000000044111325016550400166630ustar00rootroot00000000000000--- :name: zlaset :md5sum: 9941400dd2c21dc0dc6001ceb3e73b8d :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - beta: :type: doublecomplex :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlasr000077500000000000000000000140641325016550400165210ustar00rootroot00000000000000--- :name: zlasr :md5sum: 2c139334c18fea83b86ce843062afbb9 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - m-1 - s: :type: doublereal :intent: input :dims: - m-1 - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlassq000077500000000000000000000042321325016550400166770ustar00rootroot00000000000000--- :name: zlassq :md5sum: e346894954ce60bf7035bd1e4a6f75c3 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: doublereal :intent: input/output - sumsq: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlaswp000077500000000000000000000045071325016550400167070ustar00rootroot00000000000000--- :name: zlaswp :md5sum: 2ea0638539d177d84800143b1f60e3e4 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlasyf000077500000000000000000000106641325016550400167000ustar00rootroot00000000000000--- :name: zlasyf :md5sum: e54d78ff2740ce908fef577db94f64f0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: doublecomplex :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlat2c000077500000000000000000000051551325016550400165660ustar00rootroot00000000000000--- :name: zlat2c :md5sum: dcca8cca30b42aa080136a071f79dc3c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: complex :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,n) :fortran_help: " 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 conversion 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" ruby-lapack-1.8.1/dev/defs/zlatbs000077500000000000000000000171061325016550400166650ustar00rootroot00000000000000--- :name: zlatbs :md5sum: b9a44e5a032a473e82cf84ccdbe79041 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlatdf000077500000000000000000000116431325016550400166520ustar00rootroot00000000000000--- :name: zlatdf :md5sum: a3e258a309f756a498efa03aacc75a5a :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: doublecomplex :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: doublecomplex :intent: input/output :dims: - n - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " 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 chosen 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" ruby-lapack-1.8.1/dev/defs/zlatps000077500000000000000000000163671325016550400167130ustar00rootroot00000000000000--- :name: zlatps :md5sum: 081885c5bc188c12f74e8c900ae574d9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - x: :type: doublecomplex :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlatrd000077500000000000000000000140761325016550400166710ustar00rootroot00000000000000--- :name: zlatrd :md5sum: ae6def33901a9d780e3ccd3da388b4a5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - w: :type: doublecomplex :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlatrs000077500000000000000000000171651325016550400167120ustar00rootroot00000000000000--- :name: zlatrs :md5sum: 7ee5a9584440f5928720414c337c052d :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlatrz000077500000000000000000000066361325016550400167220ustar00rootroot00000000000000--- :name: zlatrz :md5sum: 0af09c4ea0283533c27d147138430ba3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - m - work: :type: doublecomplex :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlatzm000077500000000000000000000072521325016550400167100ustar00rootroot00000000000000--- :name: zlatzm :md5sum: 45cc18e2b860b2494dfd1b976ed8f61b :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input - c1: :type: doublecomplex :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: doublecomplex :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlauu2000077500000000000000000000041451325016550400166070ustar00rootroot00000000000000--- :name: zlauu2 :md5sum: 46fcd96cf0ef4dc6978b64ca0ec2df0c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zlauum000077500000000000000000000041431325016550400167000ustar00rootroot00000000000000--- :name: zlauum :md5sum: 9baf610b7968d0f2dca16da19ee72436 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbcon000077500000000000000000000060671325016550400166650ustar00rootroot00000000000000--- :name: zpbcon :md5sum: dbeb25aefa4d76514d1bf4c3290a6939 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbequ000077500000000000000000000063011325016550400166670ustar00rootroot00000000000000--- :name: zpbequ :md5sum: 2a11d91c2d32ad2d3816f333fb440f5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbrfs000077500000000000000000000121201325016550400166630ustar00rootroot00000000000000--- :name: zpbrfs :md5sum: 772ad90aaaf5530161b964fe7ede2bfb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbstf000077500000000000000000000077621325016550400167050ustar00rootroot00000000000000--- :name: zpbstf :md5sum: cfe511b95e98a455f985fa82d1816452 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbsv000077500000000000000000000114271325016550400165320ustar00rootroot00000000000000--- :name: zpbsv :md5sum: 623d43399d1b4bef8bd502dca8eb4707 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbsvx000077500000000000000000000276541325016550400167330ustar00rootroot00000000000000--- :name: zpbsvx :md5sum: 10461d4ad60f29592cf9eca8262b0e6a :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbtf2000077500000000000000000000071401325016550400165720ustar00rootroot00000000000000--- :name: zpbtf2 :md5sum: bf0e4da7634cbb13842e62dcb88bc4af :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbtrf000077500000000000000000000067631325016550400167040ustar00rootroot00000000000000--- :name: zpbtrf :md5sum: e08b91b667e36e9d1e0d906dfc043067 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpbtrs000077500000000000000000000061201325016550400167040ustar00rootroot00000000000000--- :name: zpbtrs :md5sum: 6cb711d6aca361e6d95f0a88051dda8c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpftrf000077500000000000000000000157051325016550400167040ustar00rootroot00000000000000--- :name: zpftrf :md5sum: 61ddc3c3f976621b0f6d627166ae8a57 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpftri000077500000000000000000000152321325016550400167020ustar00rootroot00000000000000--- :name: zpftri :md5sum: 43c1c7ce98a803f789417702484a41a1 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpftrs000077500000000000000000000147121325016550400167160ustar00rootroot00000000000000--- :name: zpftrs :md5sum: 6c99990622f6c51eba397f04e0c5e92f :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpocon000077500000000000000000000047571325016550400167060ustar00rootroot00000000000000--- :name: zpocon :md5sum: 732372d3f7464a9247ca90003ad28437 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpoequ000077500000000000000000000050631325016550400167100ustar00rootroot00000000000000--- :name: zpoequ :md5sum: 1019992820d3deca34591f65cbb2c774 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpoequb000077500000000000000000000050661325016550400170550ustar00rootroot00000000000000--- :name: zpoequb :md5sum: fcbf97ac05d2134d5a013144e6a8d278 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zporfs000077500000000000000000000115441325016550400167110ustar00rootroot00000000000000--- :name: zporfs :md5sum: 4bc4a31a427ae54f3a7c9845be815a3d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zporfsx000077500000000000000000000370761325016550400171110ustar00rootroot00000000000000--- :name: zporfsx :md5sum: ba57da39ddef83ee555ab5e394b61c61 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zposv000077500000000000000000000070721325016550400165500ustar00rootroot00000000000000--- :name: zposv :md5sum: e38d6624ec2ed6919290514116fa9a0d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zposvx000077500000000000000000000257131325016550400167420ustar00rootroot00000000000000--- :name: zposvx :md5sum: 1f3aee2761dee9a6b8c69a6d6362d83d :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zposvxx000077500000000000000000000505721325016550400171330ustar00rootroot00000000000000--- :name: zposvxx :md5sum: 9520bbcc218f403f56ee61a9968ac608 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/zpotf2000077500000000000000000000047241325016550400166140ustar00rootroot00000000000000--- :name: zpotf2 :md5sum: 1f423a28af00c579ba564960eb3c801f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpotrf000077500000000000000000000045751325016550400167200ustar00rootroot00000000000000--- :name: zpotrf :md5sum: cbd658bc78bbb93bab7a06a58884ba99 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpotri000077500000000000000000000041371325016550400167150ustar00rootroot00000000000000--- :name: zpotri :md5sum: d9cbd3d8000d34f9dbd5b622fb106900 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpotrs000077500000000000000000000042161325016550400167250ustar00rootroot00000000000000--- :name: zpotrs :md5sum: 86f72d1107e046da306dfe0cef88d7fd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zppcon000077500000000000000000000051751325016550400167020ustar00rootroot00000000000000--- :name: zppcon :md5sum: 0923e97bff798264005b11a3a98e98b6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zppequ000077500000000000000000000054521325016550400167130ustar00rootroot00000000000000--- :name: zppequ :md5sum: a76caef1a7119edfff5a313f2a6c2966 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpprfs000077500000000000000000000110211325016550400167000ustar00rootroot00000000000000--- :name: zpprfs :md5sum: addabb06f1320fc4046bab06d84f0935 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zppsv000077500000000000000000000075731325016550400165570ustar00rootroot00000000000000--- :name: zppsv :md5sum: 16fdc72e2738bd7a738685cfb005158d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zppsvx000077500000000000000000000261251325016550400167410ustar00rootroot00000000000000--- :name: zppsvx :md5sum: 9992fe999469ef1a85a5d74b06ea05d7 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpptrf000077500000000000000000000051711325016550400167120ustar00rootroot00000000000000--- :name: zpptrf :md5sum: d79b305b7c8dc089f8d4fbd0172bd7d5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpptri000077500000000000000000000036461325016550400167220ustar00rootroot00000000000000--- :name: zpptri :md5sum: 8ed87fedb50a3809ea9372f275d042e6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpptrs000077500000000000000000000052141325016550400167250ustar00rootroot00000000000000--- :name: zpptrs :md5sum: d37e45414eb53199139da50e79aa0dc5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpstf2000077500000000000000000000070171325016550400166160ustar00rootroot00000000000000--- :name: zpstf2 :md5sum: 44897d97885d7cb615a9081094c0d4f3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpstrf000077500000000000000000000070151325016550400167140ustar00rootroot00000000000000--- :name: zpstrf :md5sum: f241adc9e5b2e3a5588055b546367490 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zptcon000077500000000000000000000050301325016550400166740ustar00rootroot00000000000000--- :name: zptcon :md5sum: 55726a854f4ea93e20da6057c21868f0 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpteqr000077500000000000000000000104651325016550400167140ustar00rootroot00000000000000--- :name: zpteqr :md5sum: 1e06269af9687b8590d9765151765c50 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zptrfs000077500000000000000000000113571325016550400167200ustar00rootroot00000000000000--- :name: zptrfs :md5sum: b039702b9cb6d623dbf01d6a72aa8bd3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - df: :type: doublereal :intent: input :dims: - n - ef: :type: doublecomplex :intent: input :dims: - n-1 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zptsv000077500000000000000000000057131325016550400165550ustar00rootroot00000000000000--- :name: zptsv :md5sum: 616f9ce474fe61d89341347d5adc59a9 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublecomplex :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zptsvx000077500000000000000000000167021325016550400167450ustar00rootroot00000000000000--- :name: zptsvx :md5sum: f74ed0acaf4ad8aafce833be62fc059b :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - df: :type: doublereal :intent: input/output :dims: - n - ef: :type: doublecomplex :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpttrf000077500000000000000000000037641325016550400167240ustar00rootroot00000000000000--- :name: zpttrf :md5sum: 732937c80869a4f03cc38b05c7bf0531 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublecomplex :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zpttrs000077500000000000000000000063751325016550400167420ustar00rootroot00000000000000--- :name: zpttrs :md5sum: ea4804bfafab003158ad8975579e6d8a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zptts2000077500000000000000000000056011325016550400166310ustar00rootroot00000000000000--- :name: zptts2 :md5sum: 3913b63799343492f4ef48be21c0b157 :category: :subroutine :arguments: - iuplo: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zrot000077500000000000000000000037511325016550400163650ustar00rootroot00000000000000--- :name: zrot :md5sum: 78d0f66ef5b739cafe490eed4531ebec :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: doublecomplex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: doublereal :intent: input - s: :type: doublecomplex :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zspcon000077500000000000000000000051231325016550400166760ustar00rootroot00000000000000--- :name: zspcon :md5sum: b106db9eb942e1f94d952f6558892bb4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zspmv000077500000000000000000000077651325016550400165570ustar00rootroot00000000000000--- :name: zspmv :md5sum: 99c666f5d7f41498747544b9d29ffc22 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - ap: :type: doublecomplex :intent: input :dims: - ( n*( n + 1 ) )/2 - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: doublecomplex :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zspr000077500000000000000000000067571325016550400163760ustar00rootroot00000000000000--- :name: zspr :md5sum: 1b45f732167d7f16a56853c51464aade :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ( n*( n + 1 ) )/2 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsprfs000077500000000000000000000115051325016550400167120ustar00rootroot00000000000000--- :name: zsprfs :md5sum: 7caa9964208d29c528d9fd5d91110b07 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zspsv000077500000000000000000000115531325016550400165530ustar00rootroot00000000000000--- :name: zspsv :md5sum: 26289b85325f5450899fbb59ff11eb24 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zspsvx000077500000000000000000000226761325016550400167530ustar00rootroot00000000000000--- :name: zspsvx :md5sum: 9c40d411fd1ff7d129647eafdb7a0405 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsptrf000077500000000000000000000115701325016550400167150ustar00rootroot00000000000000--- :name: zsptrf :md5sum: ccd21e8c310e6967f17c079115edb9d9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsptri000077500000000000000000000047331325016550400167230ustar00rootroot00000000000000--- :name: zsptri :md5sum: 67e0485ac6f1e73b1946a7a103fd21e5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsptrs000077500000000000000000000046671325016550400167430ustar00rootroot00000000000000--- :name: zsptrs :md5sum: d02dfce2a8e5b00442505e8d2142b19d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zstedc000077500000000000000000000174771325016550400166750ustar00rootroot00000000000000--- :name: zstedc :md5sum: 369d6e9078072178eaab9195160df8f7 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :dims: - MAX(1,lrwork) - 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 :dims: - MAX(1,liwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zstegr000077500000000000000000000207631325016550400167070ustar00rootroot00000000000000--- :name: zstegr :md5sum: 49832177055455b53b056123ac827dbc :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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 compatibility 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" ruby-lapack-1.8.1/dev/defs/zstein000077500000000000000000000121111325016550400166710ustar00rootroot00000000000000--- :name: zstein :md5sum: e31fefcd280e4ed544d4a3d6fa703ad2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: doublereal :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zstemr000077500000000000000000000314011325016550400167040ustar00rootroot00000000000000--- :name: zstemr :md5sum: 18429e0d76905fc8f0eb2c094229686f :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsteqr000077500000000000000000000072461325016550400167220ustar00rootroot00000000000000--- :name: zsteqr :md5sum: 9473dd32ba01e32fce8c973a305d064a :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsycon000077500000000000000000000052641325016550400167150ustar00rootroot00000000000000--- :name: zsycon :md5sum: 3caa5f8f193ae08f62f6bc017fca8b5a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsyconv000077500000000000000000000051451325016550400171010ustar00rootroot00000000000000--- :name: zsyconv :md5sum: 2f9890567fa95c147b575de68e48b3da :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsyequb000077500000000000000000000065401325016550400170700ustar00rootroot00000000000000--- :name: zsyequb :md5sum: 7838e61ddaf85695089baeff8d3a0914 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsymv000077500000000000000000000101371325016550400165530ustar00rootroot00000000000000--- :name: zsymv :md5sum: f54cbfcd1edd0de7ed54505e307a23e0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: doublecomplex :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsyr000077500000000000000000000067171325016550400164030ustar00rootroot00000000000000--- :name: zsyr :md5sum: 33a5282ed2c27e74161752edaa7271f7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsyrfs000077500000000000000000000123131325016550400167210ustar00rootroot00000000000000--- :name: zsyrfs :md5sum: ca1036491c4d3d48e02c2ca40d621659 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsyrfsx000077500000000000000000000376141325016550400171240ustar00rootroot00000000000000--- :name: zsyrfsx :md5sum: 2a39f78dee92e9988bf64c5a25b2d5f2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsysv000077500000000000000000000127741325016550400165720ustar00rootroot00000000000000--- :name: zsysv :md5sum: d9c87655fe579731fe5a3d20af290357 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsysvx000077500000000000000000000235661325016550400167630ustar00rootroot00000000000000--- :name: zsysvx :md5sum: 656a5f89da3c81bca3d7d209e7e5939a :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsysvxx000077500000000000000000000515651325016550400171530ustar00rootroot00000000000000--- :name: zsysvxx :md5sum: 3f3062455b8eddc6564c8ef135aac476 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " 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 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" ruby-lapack-1.8.1/dev/defs/zsyswapr000077500000000000000000000043571325016550400172740ustar00rootroot00000000000000--- :name: zsyswapr :md5sum: a06299b5ca7909daadcca4963ee3a42b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytf2000077500000000000000000000127611325016550400166310ustar00rootroot00000000000000--- :name: zsytf2 :md5sum: 1d96936fe2732003778e4d2042675625 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytrf000077500000000000000000000145141325016550400167270ustar00rootroot00000000000000--- :name: zsytrf :md5sum: 9c93e85cbf5380c2c19fa9764c96cc12 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytri000077500000000000000000000051031325016550400167240ustar00rootroot00000000000000--- :name: zsytri :md5sum: 0b41f14d19118a107c85c7fede211213 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytri2000077500000000000000000000074261325016550400170200ustar00rootroot00000000000000--- :name: zsytri2 :md5sum: 250ab7ce23ae359ab3d198b664d5bf4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" lwork: (n+nb+1)*(nb+3) nb: ilaenv_(&c__1, "ZSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytri2x000077500000000000000000000053301325016550400172000ustar00rootroot00000000000000--- :name: zsytri2x :md5sum: df62985a9e25f0e54a4d290a33c25c5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytrs000077500000000000000000000050101325016550400167330ustar00rootroot00000000000000--- :name: zsytrs :md5sum: 0ac949a3605c07adf342125aa507bb44 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zsytrs2000077500000000000000000000052611325016550400170250ustar00rootroot00000000000000--- :name: zsytrs2 :md5sum: e48a2eb0aa983b9ea713ab0769adbe87 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztbcon000077500000000000000000000063371325016550400166710ustar00rootroot00000000000000--- :name: ztbcon :md5sum: 44bfad5070510971c7f6dac7609ca25b :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztbrfs000077500000000000000000000120061325016550400166720ustar00rootroot00000000000000--- :name: ztbrfs :md5sum: 0d120f06aea8ac5f348b168e747d158f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztbtrs000077500000000000000000000067031325016550400167170ustar00rootroot00000000000000--- :name: ztbtrs :md5sum: f5db47eaff35ac41a9679726933de724 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztfsm000077500000000000000000000225361325016550400165340ustar00rootroot00000000000000--- :name: ztfsm :md5sum: bed1c95a4d04ac36ac05706919521fe2 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztftri000077500000000000000000000154721325016550400167140ustar00rootroot00000000000000--- :name: ztftri :md5sum: 3bd41cf0bc65085617b31fb5b3448085 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztfttp000077500000000000000000000141761325016550400167250ustar00rootroot00000000000000--- :name: ztfttp :md5sum: 2f906623dea66c0b3bed7217e28c6507 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublecomplex :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztfttr000077500000000000000000000147321325016550400167250ustar00rootroot00000000000000--- :name: ztfttr :md5sum: 19f4fd1962dcfce8cdbea1c9e2eff0ab :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublecomplex :intent: input :dims: - ldarf - a: :type: doublecomplex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(8*ldarf+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgevc000077500000000000000000000151371325016550400166720ustar00rootroot00000000000000--- :name: ztgevc :md5sum: bae3f0de8622f9b5da908703d038acb9 :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: doublecomplex :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: doublecomplex :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: doublecomplex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgex2000077500000000000000000000117111325016550400166050ustar00rootroot00000000000000--- :name: ztgex2 :md5sum: 846b12fba6b25d431f2510d76148309e :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - "wantq ? ldq : 0" - "wantq ? n : 0" - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantq ? ldz : 0" - "wantq ? n : 0" - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgexc000077500000000000000000000137631325016550400166770ustar00rootroot00000000000000--- :name: ztgexc :md5sum: 1802c26e89d51c5c4d73a4bd2b40e40b :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgsen000077500000000000000000000375521325016550400167070ustar00rootroot00000000000000--- :name: ztgsen :md5sum: 87009453b32005aef76d43901d546116 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: doublereal :intent: output - pr: :type: doublereal :intent: output - dif: :type: doublereal :intent: output :dims: - "2" - work: :type: doublecomplex :intent: output :dims: - 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: - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgsja000077500000000000000000000260441325016550400166710ustar00rootroot00000000000000--- :name: ztgsja :md5sum: 4357a596a3013c7a9d950eff2a6b2895 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublecomplex :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgsna000077500000000000000000000237521325016550400167000ustar00rootroot00000000000000--- :name: ztgsna :md5sum: bff5e5cd558b65294a02f7c17439aad7 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublecomplex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - dif: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n+2" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgsy2000077500000000000000000000176041325016550400166330ustar00rootroot00000000000000--- :name: ztgsy2 :md5sum: 4250a5a6ef42ca889363cd7d0210dab7 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublecomplex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublecomplex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublecomplex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztgsyl000077500000000000000000000225631325016550400167250ustar00rootroot00000000000000--- :name: ztgsyl :md5sum: 5c0a55052a20a73bcdac4d22cbfd8012 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublecomplex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublecomplex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublecomplex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - dif: :type: doublereal :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztpcon000077500000000000000000000055431325016550400167050ustar00rootroot00000000000000--- :name: ztpcon :md5sum: 900599a9d663838136fafdce8c072da9 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztprfs000077500000000000000000000111651325016550400167150ustar00rootroot00000000000000--- :name: ztprfs :md5sum: 0ad6c6044e04b9f8287f22946398270a :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztptri000077500000000000000000000052171325016550400167220ustar00rootroot00000000000000--- :name: ztptri :md5sum: 604c2ba8d0abc266318f80f050d207c6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztptrs000077500000000000000000000057261325016550400167410ustar00rootroot00000000000000--- :name: ztptrs :md5sum: a47aaeb2af101fd548f7d59fe6733d53 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztpttf000077500000000000000000000142161325016550400167200ustar00rootroot00000000000000--- :name: ztpttf :md5sum: 9c832135eafbf9d3f6022c7f700da5d3 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztpttr000077500000000000000000000044521325016550400167350ustar00rootroot00000000000000--- :name: ztpttr :md5sum: 5ed67b9d6cd4f4d7c52337ecbb99e07f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - a: :type: doublecomplex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8-1.0f)-1)/2 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrcon000077500000000000000000000061541325016550400167060ustar00rootroot00000000000000--- :name: ztrcon :md5sum: 2ddd97473ce42e3675346106a0b53f3e :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrevc000077500000000000000000000147471325016550400167130ustar00rootroot00000000000000--- :name: ztrevc :md5sum: ec49fff50379686734c9e1b3cd5bcaad :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublecomplex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrexc000077500000000000000000000062271325016550400167070ustar00rootroot00000000000000--- :name: ztrexc :md5sum: 22440e97c892aee6b265e87024968d43 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrrfs000077500000000000000000000116231325016550400167160ustar00rootroot00000000000000--- :name: ztrrfs :md5sum: 794fda595394da3ba558276fc668ed14 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrsen000077500000000000000000000210571325016550400167130ustar00rootroot00000000000000--- :name: ztrsen :md5sum: 7f40c848c34c5c1a032580d2374319f6 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: doublereal :intent: output - sep: :type: doublereal :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - 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 :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrsna000077500000000000000000000167731325016550400167200ustar00rootroot00000000000000--- :name: ztrsna :md5sum: 339c335b53f98021869d2715ea8e18f8 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublecomplex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - sep: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrsyl000077500000000000000000000071171325016550400167360ustar00rootroot00000000000000--- :name: ztrsyl :md5sum: b74a0884c540a69b1720f8f96006957c :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrti2000077500000000000000000000045551325016550400166300ustar00rootroot00000000000000--- :name: ztrti2 :md5sum: 270e046b9b0d3f1c0bff663a3feeab5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrtri000077500000000000000000000046001325016550400167170ustar00rootroot00000000000000--- :name: ztrtri :md5sum: 843b034565f063ef35a59608bd92e376 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrtrs000077500000000000000000000065221325016550400167360ustar00rootroot00000000000000--- :name: ztrtrs :md5sum: 8c053191eeb4d8f06ee6f6547433d23e :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrttf000077500000000000000000000146751325016550400167330ustar00rootroot00000000000000--- :name: ztrttf :md5sum: 41673e3e78a3bb5093e17504697ba277 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztrttp000077500000000000000000000044011325016550400167270ustar00rootroot00000000000000--- :name: ztrttp :md5sum: a44dba928c85704365bac0d60caba0c2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztzrqf000077500000000000000000000064461325016550400167330ustar00rootroot00000000000000--- :name: ztzrqf :md5sum: 00c8f4cc856a90b144228b80089890df :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/ztzrzf000077500000000000000000000102161325016550400167320ustar00rootroot00000000000000--- :name: ztzrzf :md5sum: 71b51f416a0713c90c0b4492f3d3457b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - m - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunbdb000077500000000000000000000215751325016550400166570ustar00rootroot00000000000000--- :name: zunbdb :md5sum: d974370cb07cbf7b36573d0df6d5be03 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublecomplex :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: doublecomplex :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: doublecomplex :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: doublecomplex :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - q - phi: :type: doublereal :intent: output :dims: - q-1 - taup1: :type: doublecomplex :intent: output :dims: - p - taup2: :type: doublecomplex :intent: output :dims: - m-p - tauq1: :type: doublecomplex :intent: output :dims: - q - tauq2: :type: doublecomplex :intent: output :dims: - m-q - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zuncsd000077500000000000000000000205331325016550400166720ustar00rootroot00000000000000--- :name: zuncsd :md5sum: f820000ebe86f9c39a15b07a7082cf5d :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublecomplex :intent: input :dims: - p - q - ldx11: :type: integer :intent: input - x12: :type: doublecomplex :intent: input :dims: - p - m-q - ldx12: :type: integer :intent: input - x21: :type: doublecomplex :intent: input :dims: - p - q - ldx21: :type: integer :intent: input - x22: :type: doublecomplex :intent: input :dims: - p - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: doublecomplex :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: doublecomplex :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublecomplex :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: doublecomplex :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" 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 ldx12: p ldx21: p ldx22: p :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zung2l000077500000000000000000000044671325016550400166150ustar00rootroot00000000000000--- :name: zung2l :md5sum: 4673fb5058f789d5a4b6628595472cbd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zung2r000077500000000000000000000044631325016550400166170ustar00rootroot00000000000000--- :name: zung2r :md5sum: 0a4e8b42c3f0427ffcc3bf1dcc07386e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungbr000077500000000000000000000105311325016550400166700ustar00rootroot00000000000000--- :name: zungbr :md5sum: 3f925e9eac5d8de52577cb97d814c82a :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - MIN(m,k) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunghr000077500000000000000000000056461325016550400167110ustar00rootroot00000000000000--- :name: zunghr :md5sum: c69252dcf588a9af5c57d21ca126f764 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungl2000077500000000000000000000044331325016550400166060ustar00rootroot00000000000000--- :name: zungl2 :md5sum: 83082cb495e710244929a7f2d99d4246 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunglq000077500000000000000000000057261325016550400167130ustar00rootroot00000000000000--- :name: zunglq :md5sum: 9b70bf35a8d9a6feceba04344bf82610 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungql000077500000000000000000000057671325016550400167200ustar00rootroot00000000000000--- :name: zungql :md5sum: 953f5696164d9977e6b295e5ab72e66c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungqr000077500000000000000000000057631325016550400167220ustar00rootroot00000000000000--- :name: zungqr :md5sum: 7b643868b80fc48ab43e7a76954d6b60 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungr2000077500000000000000000000044571325016550400166220ustar00rootroot00000000000000--- :name: zungr2 :md5sum: 4a30cf54fa461d95f7ab0a1082f797c4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungrq000077500000000000000000000057511325016550400167170ustar00rootroot00000000000000--- :name: zungrq :md5sum: 508241447b80f0014a07bd49196f1875 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zungtr000077500000000000000000000055141325016550400167170ustar00rootroot00000000000000--- :name: zungtr :md5sum: d19f85a6bbd5f0ff4e71639186927cd5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunm2l000077500000000000000000000073221325016550400166140ustar00rootroot00000000000000--- :name: zunm2l :md5sum: 29b20cea181e052fe946c78217df8872 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunm2r000077500000000000000000000073231325016550400166230ustar00rootroot00000000000000--- :name: zunm2r :md5sum: f0c7b1706a9a0b57a6e942c453151964 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmbr000077500000000000000000000142651325016550400167060ustar00rootroot00000000000000--- :name: zunmbr :md5sum: 39e1a87077ff3d4f0239a32149d77cc5 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - MIN(nq,k) - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmhr000077500000000000000000000122641325016550400167110ustar00rootroot00000000000000--- :name: zunmhr :md5sum: 453fec5987903314df5d90693637fa0f :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - m-1 - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunml2000077500000000000000000000073601325016550400166160ustar00rootroot00000000000000--- :name: zunml2 :md5sum: e27ef006d74c26f3884a48ee719ffdda :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmlq000077500000000000000000000105751325016550400167170ustar00rootroot00000000000000--- :name: zunmlq :md5sum: 83a4204ef6a273e82e35b38f0fd5c3ab :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmql000077500000000000000000000105271325016550400167140ustar00rootroot00000000000000--- :name: zunmql :md5sum: 47e081e59b96669df3b317550a70d83c :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmqr000077500000000000000000000105421325016550400167170ustar00rootroot00000000000000--- :name: zunmqr :md5sum: 03aa2db16b2f96e7e6935ea901f2b1aa :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmr2000077500000000000000000000073571325016550400166320ustar00rootroot00000000000000--- :name: zunmr2 :md5sum: 6bd0a8cf80613c3965370e82e015fa65 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmr3000077500000000000000000000112251325016550400166200ustar00rootroot00000000000000--- :name: zunmr3 :md5sum: 9936c02446a1fbd2f55c0aad91334345 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmrq000077500000000000000000000105641325016550400167230ustar00rootroot00000000000000--- :name: zunmrq :md5sum: 2f8b6c1c9742562afec7489e83cac105 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmrz000077500000000000000000000115121325016550400167260ustar00rootroot00000000000000--- :name: zunmrz :md5sum: 4852187a5574f9f5bf22da48e0265e54 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zunmtr000077500000000000000000000117211325016550400167220ustar00rootroot00000000000000--- :name: zunmtr :md5sum: d9162f3d836aaf44831702b03f6edbaa :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - m-1 - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zupgtr000077500000000000000000000045061325016550400167210ustar00rootroot00000000000000--- :name: zupgtr :md5sum: 924fd32a52613919c09c91f16d7e0fa6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - tau: :type: doublecomplex :intent: input :dims: - ldtau - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " 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" ruby-lapack-1.8.1/dev/defs/zupmtr000077500000000000000000000071701325016550400167270ustar00rootroot00000000000000--- :name: zupmtr :md5sum: 2c774ae5c8f3bf8176eb3968138221b8 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - m*(m+1)/2 - tau: :type: doublecomplex :intent: input :dims: - m-1 - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.8.1/dev/make_csrc.rb000077500000000000000000000540501325016550400167750ustar00rootroot00000000000000$:.unshift File.dirname(__FILE__) require "yaml" require "pp" require "common" RBPREFIX = "rblapack_" NATYPES = { "integer" => "NA_LINT", "real" => "NA_SFLOAT", "doublereal" => "NA_DFLOAT", "complex" => "NA_SCOMPLEX", "doublecomplex" => "NA_DCOMPLEX", "logical" => "NA_LINT", } USEXBLAS = %w( gesvxx gerfsx la_gerfsx_extended la_geamv la_gercond la_gercond_c la_gercond_x la_rpvgrw la_gerpvgrw sysvxx syrfsx la_syrfsx_extended la_syamv la_syrcond la_syrpvgrw la_syrcond_c la_syrcond_x posvxx porfsx la_porfsx_extended la_porcond la_porcond_c la_porcond_x la_porpvgrw gbsvxx gbrfsx la_gbrfsx_extended hesvxx herfsx la_herfsx_extended la_heamv la_hercond_c la_hercond_x la_herpvgrw la_gbamv la_gbrcond la_gbrcond_c la_gbrcond_x la_gbrpvgrw la_lin_berr larscl2 lascl2 la_wwaddw ) TOPDIR = File.join(File.dirname(__FILE__), "..") def get_cobj(name, type, sub_name, indent=2) indent = " "*indent case type when "integer" return "#{indent}#{name} = NUM2INT(#{RBPREFIX}#{name});\n" when "real" return "#{indent}#{name} = (real)NUM2DBL(#{RBPREFIX}#{name});\n" when "doublereal" return "#{indent}#{name} = NUM2DBL(#{RBPREFIX}#{name});\n" when "complex" code =<<"EOF" #{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" code =<<"EOF" #{name}.r = NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("real"), 0)); #{name}.i = NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("imag"), 0)); EOF return code when "char" return " #{name} = StringValueCStr(#{RBPREFIX}#{name})[0];\n" when "logical" return " #{name} = (#{RBPREFIX}#{name} == Qtrue);\n" else raise "type (#{type}) is not defined in #{name} (#{sub_name})" end end def get_robj(name, type, flag=false) case type when "integer" cname = flag ? "(*#{name})" : name return " #{RBPREFIX}#{name} = INT2NUM(#{cname});\n" when "real", "doublereal" cname = flag ? "(*#{name})" : name return " #{RBPREFIX}#{name} = rb_float_new((double)#{cname});\n" when "complex", "doublecomplex" if flag r = "(#{name}->r)" i = "(#{name}->i)" else r = "(#{name}.r)" i = "(#{name}.i)" end return " #{RBPREFIX}#{name} = rb_funcall(rb_gv_get(\"Complex\"), rb_intern(\"new\"), 2, rb_float_new((double)#{r}), rb_float_new((double)#{i}));\n" when "char" return " #{RBPREFIX}#{name} = rb_str_new(&#{name},1);\n" when "logical" return " #{RBPREFIX}#{name} = #{name} ? Qtrue : Qfalse;\n" else raise "type (#{type}) is not defined in #{name}" end end def get_input(name, type, dims, i, varset, sub_name, subst, indent=2) if dims.nil? return get_cobj(name, type, sub_name, indent) else indent = " "*indent if type == "char" return "#{indent}#{name} = StringValueCStr(#{RBPREFIX}#{name});\n" end if i.kind_of?(Integer) arg = "#{i+1}th argument" else arg = "option" end code =<<"EOF" #{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" #{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" #{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| unless varset.include?(d) || @shape.include?(d) raise "undefined #{d} #{name} #{sub_name}" end } code << <<"EOF" #{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != (#{dim})) #{indent} rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be %d", #{dim}); EOF else code << "#{indent}#{dim} = NA_SHAPE#{j}(#{RBPREFIX}#{name});\n" @shape[dim] = {:name => name, :index => j} if s = subst[dim] if /^[a-z][a-z_\d]*$/ =~ s && !varset.include?(s) code << "#{indent}#{s} = #{dim};\n" varset.push s else code << < func_type} if /complex/ =~ func_type || func_type == "char" code << "extern VOID #{sub_name}_(#{func_type} *__out__, #{cargs});\n\n" else code << "extern #{func_type} #{sub_name}_(#{cargs});\n\n" end else raise "category is invalid: #{sub_type} (#{sub_name})" end usexblas = USEXBLAS.include?(sub_name[1..-1]) code << <<"EOF" static VALUE #{RBPREFIX}#{sub_name}(int argc, VALUE *argv, VALUE self){ EOF code << "#ifdef USEXBLAS\n" if usexblas dimdefs = Array.new (inputs+options+outputs).each{|aname| arg = args[aname] code << <<"EOF" VALUE #{RBPREFIX}#{aname}; #{arg[:type]} #{arg[:dims] ? "*" : ""}#{aname}; EOF dimdefs.push aname } inouts.each{|aname| arg = args[aname] if arg[:dims] code << <<"EOF" VALUE #{RBPREFIX}#{aname}_out__; #{arg[:type]} *#{aname}_out__; EOF end } if extras extras.each do |k,v| code << " #{v} #{k};\n" dimdefs.push k end end workspaces.each{|aname| arg = args[aname] code << " #{arg[:type]} #{arg[:dims] ? "*" : ""}#{aname};\n" } code << "\n" (inputs+options+outputs+workspaces).each{|aname| arg = args[aname] if dims = arg[:dims] dims.each{|dim| if dim.kind_of?(Hash) p name end if /^[a-z][a-z_\d]*$/ !~ dim # if dim is a Numeric next end unless dimdefs.include?(dim) # untill it's defined code << " integer #{dim};\n" dimdefs.push dim end } end } if ss = subst ss.each{|k,v| unless dimdefs.include?(k) code << " integer #{k};\n" dimdefs.push k end } end code << "\n" if block block_help = "{|" + ['a','b','c'][0...args[block][:block_arg_num]].join(",") + "| ... }" else block_help = "" end usage_code = <<"EOF" USAGE: #{(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" 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+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 && !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! order[arg] = {:depends => aryd, :type => :input, :order => i, :provides => aryp} end subst.each do |k,v| order[k] = {:depends => get_vars(v).uniq, :type => :subst, :value => v} end 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 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 end unless flag p "order" pp order raise "depends each others: #{oks.join(", ")} (#{sub_name})" end end order = new_order 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] if arg[:option] if arg[:default] code << < #include #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); 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; /* for compatibility for NArray and NArray with bigmem patch */ #ifndef NARRAY_BIGMEM typedef int na_shape_t; #endif EOF } 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| usexblas = USEXBLAS.include?(sname[1..-1]) file.print "#ifdef USEXBLAS\n" if usexblas file.print "extern void init_lapack_#{sname}(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE #{RBPREFIX}ZERO);\n" file.print "#endif\n" if usexblas } file.print <<"EOF" 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")); #{RBPREFIX}ZERO = INT2NUM(0); EOF sub_names.each{|sname| usexblas = USEXBLAS.include?(sname[1..-1]) file.print "#ifdef USEXBLAS\n" if usexblas file.print " init_lapack_#{sname}(mLapack, sHelp, sUsage, #{RBPREFIX}ZERO);\n" file.print "#endif\n" if usexblas } file.print "}\n" } end debug = ARGV.delete("--debug") #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 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, debug) ruby-lapack-1.8.1/dev/mkdoc.rb000077500000000000000000000140641325016550400161440ustar00rootroot00000000000000DataTypes = [ ["S", "REAL"], ["D", "DOUBLE PRECISION"], ["C", "COMPLEX"], ["Z", "COMPLEX*16 or DOUBLE COMPLEX"], ["DS", "Data type in double but solving problem using single precision"], ["ZC", "Data type in complex*16 but solving problem using complex precision"] ] MatrixTypes = [ ["BD", "bidiagonal"], ["DI", "diagonal"], ["GB", "general band"], ["GE", "general (i.e., unsymmetric, in some cases rectangular)"], ["GG", "general matrices, generalized problem (i.e., a pair of general matrices)"], ["GT", "general tridiagonal"], ["HB", "(complex) Hermitian band"], ["HE", "(complex) Hermitian"], ["HG", "upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix)"], ["HP", "(complex) Hermitian, packed storage"], ["HS", "upper Hessenberg"], ["OP", "(real) orthogonal, packed storage"], ["OR", "(real) orthogonal"], ["PB", "symmetric or Hermitian positive definite band"], ["PO", "symmetric or Hermitian positive definite"], ["PP", "symmetric or Hermitian positive definite, packed storage"], ["PT", "symmetric or Hermitian positive definite tridiagonal"], ["SB", "(real) symmetric band"], ["SP", "symmetric, packed storage"], ["ST", "(real) symmetric tridiagonal"], ["SY", "symmetric"], ["TB", "triangular band"], ["TG", "triangular matrices, generalized problem (i.e., a pair of triangular matrices)"], ["TP", "triangular, packed storage"], ["TR", "triangular (or in some cases quasi-triangular)"], ["TZ", "trapezoidal"], ["UN", "(complex) unitary"], ["UP", "(complex) unitary, packed storageBDbidiagonal"] ] require "numru/lapack" include NumRu prefix = File.dirname(__FILE__)+"/../doc" desc = Hash.new 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 reg = /^#{cdt}#{cmt}/ ms = Array.new dmethods.each{|m| next unless reg =~ m ms.push m } 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" #{dt} routines for #{mt} matrix

#{dt} routines for #{mt} matrix

    EOF ms.each{|m| file.print <<"EOF"
  • #{m}
  • EOF } file.print <<"EOF"
EOF ms.each{|m| file.print <<"EOF"

#{m}

EOF
          IO.popen("-") do |io|
            if io # parent
              file.print io.read
            else # child
              Lapack.send(m, :help => true)
            end
          end
          file.print <<"EOF"
    
go to the page top EOF } file.print <<"EOF"
back to matrix types
back to data types EOF } end } unless mts.empty? File.open(File.join(prefix,"#{cdt}.html"),"w"){|file| file.print <<"EOF" #{dt} routines

#{dt} routines


back to index.html 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" #{mt} routines

#{mt} routines


back to index.html EOF end end end if methods.any? File.open(File.join(prefix,"others.html"),"w") do |file| file.print < other routines

other routines

    EOF methods.each do |m| file.print <#{m} EOF end file.print < EOF methods.each do |m| file.print <

    #{m}

    EOF
          IO.popen("-") do |io|
            if io # parent
              file.print io.read
            else # child
              Lapack.send(m, :help => true)
            end
          end
          file.print <
        go to the page top
    
    EOF
        end
        file.print <<"EOF"
        
    back to index EOF end end File.open(File.join(prefix,"index.html"),"w"){|file| file.print <<"EOF" LAPACK routines

    Data types

      EOF DataTypes.each{|cdt,dt| file.print "
    • #{cdt}: #{dt}
    • \n" } file.print <<"EOF"

    Matrix types

      EOF MatrixTypes.each do |cmt,mt| if dts[cmt.downcase] file.print "
    • #{cmt}: #{mt}
    • \n" end end file.print <<"EOF"
    EOF if methods.any? file.print <others EOF end file.print <<"EOF" EOF } ruby-lapack-1.8.1/dev/parse.rb000077500000000000000000001530051325016550400161600ustar00rootroot00000000000000$:.unshift File.dirname(__FILE__) require "yaml" require "digest/md5" require "pp" require "common" CTYPES = { "INTEGER" => "integer", "CHARACTER" => "char", "REAL" => "real", "DOUBLE PRECISION" => "doublereal", "COMPLEX" => "complex", "COMPLEX*16" => "doublecomplex", "DOUBLE COMPLEX" => "doublecomplex", "LOGICAL" => "logical" } ARGS = { "csyequb" => { "uplo" => {:intent => "input", :type => "char"}, "work" => {:intent => "input", :type => "real"} }, "zsyequb" => { "uplo" => {:intent => "input", :type => "char"}, "work" => {:intent => "input", :type => "doublereal"} }, "zhfrk" => { "uplo" => {:intent => "input", :type => "char"}, "trans" => {:intent => "input", :type => "char"}, "n" => {:intent => "input", :type => "integer"}, "k" => {:intent => "input", :type => "integer"}, "alpha" => {:intent => "input", :type => "doublereal"}, "beta" => {:intent => "input", :type => "doublereal"}, "a" => {:intent => "input", :type => "doublereal"}, "lda" => {:intent => "input", :type => "integer"}, "c" => {:intent => "input", :type => "doublereal"}, }, "zpstf2" => { "work" => {:intent => "input", :type => "doublereal"} }, "ssfrk" => { "uplo" => {:intent => "input", :type => "char"}, "trans" => {:intent => "input", :type => "char"}, "n" => {:intent => "input", :type => "integer"}, "k" => {:intent => "input", :type => "integer"}, "alpha" => {:intent => "input", :type => "real"}, "beta" => {:intent => "input", :type => "real"}, "a" => {:intent => "input", :type => "real"}, "lda" => {:intent => "input", :type => "integer"}, "c" => {:intent => "input", :type => "real"}, }, "dsfrk" => { "uplo" => {:intent => "input", :type => "char"}, "trans" => {:intent => "input", :type => "char"}, "n" => {:intent => "input", :type => "integer"}, "k" => {:intent => "input", :type => "integer"}, "alpha" => {:intent => "input", :type => "doublereal"}, "beta" => {:intent => "input", :type => "doublereal"}, "a" => {:intent => "input", :type => "doublereal"}, "lda" => {:intent => "input", :type => "integer"}, "c" => {:intent => "input", :type => "doublereal"}, }, "spstf2" => { "work" => {:intent => "input", :type => "real"} }, "cheequb" => { "uplo" => {:intent => "input", :type => "char"}, "work" => {:intent => "input", :type => "complex"} }, "zheequb" => { "uplo" => {:intent => "input", :type => "char"}, "work" => {:intent => "input", :type => "doublecomplex"} }, "dsyequb" => { "uplo" => {:intent => "input", :type => "char"}, "work" => {:intent => "input", :type => "doublereal"} }, "chesvxx" => { "uplo" => {:intent => "input", :type => "char"} }, "zhesvxx" => { "uplo" => {:intent => "input", :type => "char"} }, "dgesvj" => { "lwork" => {:intent => "input", :type => "integer"} }, "dpstf2" => { "work" => {:intent => "input", :type => "doublereal"} }, "cpstf2" => { "work" => {:intent => "input", :type => "real"} }, "spstrf" => { "work" => {:intent => "input", :type => "real"} }, "dpstrf" => { "work" => {:intent => "input", :type => "doublereal"} }, "zpstrf" => { "work" => {:intent => "input", :type => "doublereal"} }, "cpstrf" => { "work" => {:intent => "input", :type => "doublereal"} }, "sgesvj" => { "lwork" => {:intent => "input", :type => "integer"} }, "sla_lin_berr" => { "berr" => {:intent => "output", :type => "real"} }, "dla_lin_berr" => { "berr" => {:intent => "output", :type => "doublereal"} }, "ssyequb" => { "uplo" => {:intent => "input", :type => "char"}, "work" => {:intent => "input", :type => "real"}, }, "slasq4" => { "n0in" => {:intent => "input", :type => "integer"}, }, "dlasq4" => { "n0in" => {:intent => "input", :type => "integer"}, }, "slaqr1" => { "si1" => {:intent => "input", :type => "real"}, "sr2" => {:intent => "input", :type => "real"}, "si2" => {:intent => "input", :type => "real"}, }, "dlaqr1" => { "si1" => {:intent => "input", :type => "doublereal"}, "sr2" => {:intent => "input", :type => "doublereal"}, "si2" => {:intent => "input", :type => "doublereal"}, }, "claqr1" => { "s2" => {:intent => "input", :type => "complex"}, }, "zlaqr1" => { "s2" => {:intent => "input", :type => "doublecomplex"}, }, "slarrf" => { "clgapl" => {:intent => "input", :type => "real"}, "clgapr" => {:intent => "input", :type => "real"}, "info" => {:intent => "output", :type => "integer"}, }, "dlarrf" => { "clgapl" => {:intent => "input", :type => "doublereal"}, "clgapr" => {:intent => "input", :type => "doublereal"}, "info" => {:intent => "output", :type => "integer"}, } } DIMS = { "strttp" => { "ap" => ["n*(n+1)/2"] }, "dtrttp" => { "ap" => ["n*(n+1)/2"] }, "stftri" => { "a" => ["n*(n+1)/2"] }, "dtftri" => { "a" => ["n*(n+1)/2"] }, "zpstrf" => { "work" => ["2*n"] }, "spftrf" => { "a" => ["n*(n+1)/2"] }, "cpftrf" => { "a" => ["n*(n+1)/2"] }, "cpftrs" => { "a" => ["n*(n+1)/2"] }, "zpftrs" => { "a" => ["n*(n+1)/2"] }, "strttf" => { "arf" => ["n*(n+1)/2"] }, "dtrttf" => { "arf" => ["n*(n+1)/2"] }, "sla_gbrfsx_extended" => { "ab" => ["ldab", "n"] }, "stgex2" => { "work" => ["lwork"] }, "dtgex2" => { "work" => ["lwork"] }, "dlasd1" => { "d" => ["n"] }, "slaruv" => { "x" => ["MAX(1,n)"] }, "dlaruv" => { "x" => ["MAX(1,n)"] }, "slasyf" => { "w" => ["ldw","MAX(1,nb)"] }, "dlasyf" => { "w" => ["ldw","MAX(1,nb)"] }, "clasyf" => { "w" => ["ldw","MAX(1,nb)"] }, "zlasyf" => { "w" => ["ldw","MAX(1,nb)"] }, "slaeda" => { "qptr" => ["ldqptr"] }, "dlaeda" => { "qptr" => ["ldqptr"] }, "slasdt" => { "inode" => ["MAX(1,n)"], "ndiml" => ["MAX(1,n)"], "ndimr" => ["MAX(1,n)"], }, "dlasdt" => { "inode" => ["MAX(1,n)"], "ndiml" => ["MAX(1,n)"], "ndimr" => ["MAX(1,n)"], }, "sgbequ" => { "r" => ["MAX(1,m)"] }, "dgbequ" => { "r" => ["MAX(1,m)"] }, "cgbequ" => { "r" => ["MAX(1,m)"] }, "zgbequ" => { "r" => ["MAX(1,m)"] }, "slaed9" => { "d" => ["MAX(1,n)"], "q" => ["ldq", "MAX(1,n)"] }, "dlaed9" => { "d" => ["MAX(1,n)"], "q" => ["ldq", "MAX(1,n)"] }, "slarnv" => { "x" => ["MAX(1,n)"], }, "dlarnv" => { "x" => ["MAX(1,n)"], }, "clarnv" => { "x" => ["MAX(1,n)"], }, "zlarnv" => { "x" => ["MAX(1,n)"] }, "slabrd" => { "d" => ["MAX(1,nb)"], "e" => ["MAX(1,nb)"], "tauq" => ["MAX(1,nb)"], "taup" => ["MAX(1,nb)"], "x" => ["ldx", "MAX(1,nb)"], "y" => ["ldy", "MAX(1,nb)"], }, "dlabrd" => { "d" => ["MAX(1,nb)"], "e" => ["MAX(1,nb)"], "tauq" => ["MAX(1,nb)"], "taup" => ["MAX(1,nb)"], "x" => ["ldx", "MAX(1,nb)"], "y" => ["ldy", "MAX(1,nb)"], }, "clabrd" => { "d" => ["MAX(1,nb)"], "e" => ["MAX(1,nb)"], "tauq" => ["MAX(1,nb)"], "taup" => ["MAX(1,nb)"], "x" => ["ldx", "MAX(1,nb)"], "y" => ["ldy", "MAX(1,nb)"], }, "zlabrd" => { "d" => ["MAX(1,nb)"], "e" => ["MAX(1,nb)"], "tauq" => ["MAX(1,nb)"], "taup" => ["MAX(1,nb)"], "x" => ["ldx", "MAX(1,nb)"], "y" => ["ldy", "MAX(1,nb)"], }, "slahr2" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "dlahr2" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "clahr2" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "zlahr2" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "slahrd" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "dlahrd" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "clahrd" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "zlahrd" => { "tau" => ["MAX(1,nb)"], "t" => ["ldt","MAX(1,nb)"], "y" => ["ldy","MAX(1,nb)"], }, "slaqr2" => { "sr" => ["MAX(1,kbot)"], "si" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldt", "MAX(1,nw)"], "wv" => ["ldwv", "MAX(1,nw)"], }, "dlaqr2" => { "sr" => ["MAX(1,kbot)"], "si" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldt", "MAX(1,nw)"], "wv" => ["ldwv", "MAX(1,nw)"], }, "claqr2" => { "sh" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldv", "MAX(1,nw)"], "wv" => ["ldv", "MAX(1,nw)"], }, "zlaqr2" => { "sh" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldv", "MAX(1,nw)"], "wv" => ["ldv", "MAX(1,nw)"], }, "slaqr3" => { "sr" => ["MAX(1,kbot)"], "si" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldt", "MAX(1,nw)"], "wv" => ["ldwv", "MAX(1,nw)"], }, "dlaqr3" => { "sr" => ["MAX(1,kbot)"], "si" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldt", "MAX(1,nw)"], "wv" => ["ldwv", "MAX(1,nw)"], }, "claqr3" => { "sh" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldv", "MAX(1,nw)"], "wv" => ["ldv", "MAX(1,nw)"], }, "zlaqr3" => { "sh" => ["MAX(1,kbot)"], "v" => ["ldv", "MAX(1,nw)"], "t" => ["ldv", "MAX(1,nw)"], "wv" => ["ldv", "MAX(1,nw)"], }, "slatrd" => { "w" => ["ldw", "MAX(n,nb)"] }, "dlatrd" => { "w" => ["ldw", "MAX(n,nb)"] }, "clatrd" => { "w" => ["ldw", "MAX(n,nb)"] }, "zlatrd" => { "w" => ["ldw", "MAX(n,nb)"] }, "clahef" => { "w" => ["ldw", "MAX(n,nb)"] }, "zlahef" => { "w" => ["ldw", "MAX(n,nb)"] }, "sopgtr" => { "ap" => ["ldap"], "tau" => ["ldtau"], }, "dopgtr" => { "ap" => ["ldap"], "tau" => ["ldtau"], }, "cupgtr" => { "ap" => ["ldap"], "tau" => ["ldtau"], }, "zupgtr" => { "ap" => ["ldap"], "tau" => ["ldtau"], }, "ssptrd" => { "ap" => ["ldap"] }, "dsptrd" => { "ap" => ["ldap"] }, "chptrd" => { "ap" => ["ldap"] }, "zhptrd" => { "ap" => ["ldap"] }, "sspgv" => { "ap" => ["ldap"] }, "chpev" => { "ap" => ["ldap"], }, "zhpev" => { "ap" => ["ldap"], }, "chpevx" => { "ap" => ["ldap"], }, "zhpevx" => { "ap" => ["ldap"], }, "dspgv" => { "ap" => ["ldap"] }, "sppequ" => { "ap" => ["ldap"] }, "dppequ" => { "ap" => ["ldap"] }, "cppequ" => { "ap" => ["ldap"] }, "zppequ" => { "ap" => ["ldap"] }, "sspgvd" => { "ap" => ["ldap"] }, "dspgvd" => { "ap" => ["ldap"] }, "stpcon" => { "ap" => ["ldap"] }, "dtpcon" => { "ap" => ["ldap"] }, "ctpcon" => { "ap" => ["ldap"] }, "ztpcon" => { "ap" => ["ldap"] }, "sspgvx" => { "ap" => ["ldap"], }, "dspgvx" => { "ap" => ["ldap"], }, "chpevd" => { "ap" => ["ldap"], }, "zhpevd" => { "ap" => ["ldap"], }, "sspev" => { "ap" => ["ldap"], }, "dspev" => { "ap" => ["ldap"], }, "sspevd" => { "ap" => ["ldap"], }, "dspevd" => { "ap" => ["ldap"], }, "sspevx" => { "ap" => ["ldap"], }, "dspevx" => { "ap" => ["ldap"], }, "sppcon" => { "ap" => ["ldap"] }, "dppcon" => { "ap" => ["ldap"] }, "cppcon" => { "ap" => ["ldap"] }, "zppcon" => { "ap" => ["ldap"] }, "chpgv" => { "ap" => ["ldap"] }, "zhpgv" => { "ap" => ["ldap"] }, "chpgvd" => { "ap" => ["ldap"] }, "zhpgvd" => { "ap" => ["ldap"] }, "chpgvx" => { "ap" => ["ldap"] }, "zhpgvx" => { "ap" => ["ldap"] }, "chptrf" => { "ap" => ["ldap"] }, "zhptrf" => { "ap" => ["ldap"] }, "ssptrf" => { "ap" => ["ldap"] }, "dsptrf" => { "ap" => ["ldap"] }, "csptrf" => { "ap" => ["ldap"] }, "zsptrf" => { "ap" => ["ldap"] }, "slaqr0" => { "z" => ["ldz","ihi"] }, "dlaqr0" => { "z" => ["ldz","ihi"] }, "claqr0" => { "z" => ["ldz","ihi"], "work" => ["MAX(1,lwork)"] }, "zlaqr0" => { "z" => ["wantz ? ldz : 0","wantz ? ihi : 0"], "work" => ["MAX(1,lwork)"] }, "slaqr4" => { "z" => ["ldz","ihi"] }, "dlaqr4" => { "z" => ["ldz","ihi"] }, "claqr4" => { "z" => ["ldz","ihi"] }, "zlaqr4" => { "z" => ["ldz","ihi"] }, "slaqr5" => { "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"], "wh" => ["ldwh", "MAX(1,nh)"] }, "dlaqr5" => { "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"], "wh" => ["ldwh", "MAX(1,nh)"] }, "claqr5" => { "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"], "wh" => ["ldwh", "MAX(1,nh)"] }, "zlaqr5" => { "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"], "wh" => ["ldwh", "MAX(1,nh)"] }, "slasd0" => { "u" => ["ldu", "n"] }, "dlasd0" => { "u" => ["ldu", "n"] }, "slasd4" => { "delta" => ["n"], "work" => ["n"] }, "dlasd4" => { "delta" => ["n"], "work" => ["n"] }, "slasdq" => { "e" => ['sqre==0 ? n-1 : sqre==1 ? n : 0'], "work" => ["4*n"] }, "dlasdq" => { "e" => ['sqre==0 ? n-1 : sqre==1 ? n : 0'], "work" => ["4*n"] }, "slaed3" => { "q2" => ["n","n"] }, "dlaed3" => { "q2" => ["n","n"] }, "slaed4" => { "delta" => ["n"] }, "dlaed4" => { "delta" => ["n"] }, "slaed8" => { "q" => ['icompq==0 ? 0 : ldq', 'icompq==0 ? 0 : n'], "q2" => ['icompq==0 ? 0 : ldq2', 'icompq==0 ? 0 : n'] }, "dlaed8" => { "q" => ['icompq==0 ? 0 : ldq', 'icompq==0 ? 0 : n'], "q2" => ['icompq==0 ? 0 : ldq2', 'icompq==0 ? 0 : n'] }, "claed8" => { "q2" => ['ldq2', 'n'] }, "zlaed8" => { "q2" => ['ldq2', 'n'] }, "slasq3" => { "z" => ['4*n0'] }, "dlasq3" => { "z" => ['4*n0'] }, "slasq4" => { "z" => ['4*n0'] }, "dlasq4" => { "z" => ['4*n0'] }, "slasq5" => { "z" => ['4*n0'] }, "dlasq5" => { "z" => ['4*n0'] }, "slasq6" => { "z" => ['4*n0'] }, "dlasq6" => { "z" => ['4*n0'] }, "slazq3" => { "z" => ['4*n0'] }, "dlazq3" => { "z" => ['4*n0'] }, "slazq4" => { "z" => ['4*n0'] }, "dlazq4" => { "z" => ['4*n0'] }, "slahqr" => { "z" => ['wantz ? ldz : 0', 'wantz ? n : 0'] }, "dlahqr" => { "z" => ['wantz ? ldz : 0', 'wantz ? n : 0'] }, "clahqr" => { "z" => ['wantz ? ldz : 0', 'wantz ? n : 0'] }, "zlahqr" => { "z" => ['wantz ? ldz : 0', 'wantz ? n : 0'] }, "cpbsvx" => { "afb" => ["ldafb","n"] }, "dgesdd" => { "vt" => ["ldvt","n"] }, "slasda" => { "u" => ["ldu", "MAX(1,smlsiz)"], "s" => ['icompq==1 ? n : icompq==0 ? 1 : 0'] }, "dlasda" => { "u" => ["ldu", "MAX(1,smlsiz)"], "s" => ['icompq==1 ? n : icompq==0 ? 1 : 0'] }, "clalsa" => { "rwork" => ['MAX(n,(smlsiz+1)*nrhs*3)'] }, "zlalsa" => { "rwork" => ['MAX(n,(smlsiz+1)*nrhs*3)'] }, "stgsen" => { "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)'] }, "dtgsen" => { "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)'] }, "ztgsen" => { "work" => ['ijob==0 ? 0 : MAX(1,lwork)'], "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)'] }, "ctgsen" => { "work" => ['ijob==0 ? 0 : MAX(1,lwork)'], "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)'] }, "slarfx" => { "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0'] }, "dlarfx" => { "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0'] }, "clarfx" => { "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0'] }, "zlarfx" => { "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0'] }, "slaebz" => { "nval" => ['(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0'], "c" => ['ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0'], "nab" => ['mmax', '2'] }, "dlaebz" => { "nval" => ['(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0'], "c" => ['ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0'], "nab" => ['mmax', '2'] }, "sbdsdc" => { "u" => ['lsame_(&compq,"I") ? ldu : 0','lsame_(&compq,"I") ? n : 0'], "vt" => ['lsame_(&compq,"I") ? ldvt : 0','lsame_(&compq,"I") ? n : 0'], "q" => ['lsame_(&compq,"I") ? ldq : 0'], "iq" => ['lsame_(&compq,"I") ? ldiq : 0'], "work" => ['MAX(1,lwork)'] }, "dbdsdc" => { "u" => ['lsame_(&compq,"I") ? ldu : 0','lsame_(&compq,"I") ? n : 0'], "vt" => ['lsame_(&compq,"I") ? ldvt : 0','lsame_(&compq,"I") ? n : 0'], "q" => ['lsame_(&compq,"I") ? ldq : 0'], "iq" => ['lsame_(&compq,"I") ? ldiq : 0'], "work" => ['MAX(1,lwork)'] }, "sgelsx" => { "work" => ['MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)'] }, "dgelsx" => { "work" => ['MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)'] }, "cgelsx" => { "work" => ['MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)'] }, "zgelsx" => { "work" => ['MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)'] }, "sgeevx" => { "iwork" => ['(lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2'] }, "dgeevx" => { "iwork" => ['(lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2'] }, "ctgex2" => { "q" => ['wantq ? ldq : 0', 'wantq ? n : 0'], "z" => ['wantq ? ldz : 0', 'wantq ? n : 0'] }, "ztgex2" => { "q" => ['wantq ? ldq : 0', 'wantq ? n : 0'], "z" => ['wantq ? ldz : 0', 'wantq ? n : 0'] }, "clalsd" => { "rwork" => ['9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)'] }, "zlalsd" => { "rwork" => ['9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)'] }, "ssbgvx" => { "work" => ['7*n'], "iwork" => ['5*n'], } } TYPES = { "slarrc" => { "vl" => "real", "vu" => "real", "d" => "real", "e" => "real", "pivmin" => "real" }, "slarrb" => { "pivmin" => "real", "spdiam" => "real" }, "slarre" => { "pivmin" => "real" }, "slarrf" => { "pivmin" => "real", "spdiam" => "real" }, "dlarrf" => { "spdiam" => "doublereal" }, "slarrj" => { "pivmin" => "real", "spdiam" => "real" }, "slarrv" => { "pivmin" => "real" }, "clarrv" =>{ "pivmin" => "real" }, "zggbal" => { "work" => "doublereal" }, "clarcm" => { "b" => "complex" }, "zlarcm" => { "b" => "doublecomplex" }, "clatdf" => { "z" => "complex", "rhs" => "complex", }, "zlatdf" => { "z" => "doublecomplex", "rhs" => "doublecomplex", }, "dggbal" => { "work" => "doublereal" }, "zggevx" => { "rwork" => "doublereal" }, "dlazq3" => { "dmin1" => "doublereal", "dmin2" => "doublereal", "dn" => "doublereal", "dn1" => "doublereal", "dn2" => "doublereal", "tau" => "doublereal", }, "zlag2c" => { "a" => "doublecomplex", "sa" => "complex" }, "clag2z" => { "a" => "doublecomplex", "sa" => "complex" }, "cptts2" => { "b" => "complex" }, "zptts2" => { "b" => "doublecomplex" }, "cpttrs" => { "b" => "complex" }, "zpttrs" => { "b" => "doublecomplex" }, "zpbrfs" => { "ab" => "doublecomplex" } } SUBSTS = Hash.new SUBSTS["dlasd1"] = {"n" => "nl+nr+1"} %w(slaeda dlaeda).each{|n| SUBSTS[n] = {"n" => "ldqptr-2"}} %w(sgbbrd dgbbrd cgbbrd zgbbrd).each{|n| SUBSTS[n] = {"m" => "ldab"}} %w(sggsvp dggsvp cggsvp zggsvp sgeequ dgeequ cgeequ zgeequ cungr2 zungr2 cungl2 zungl2 sorgr2 dorgr2 sorgl2 dorgl2 stzrqf dtzrqf ctzrqf ztzrqf stzrzf dtzrzf ctzrzf ztzrzf sgerq2 dgerq2 cgerq2 zgerq2 sgelq2 dgelq2 cgelq2 zgelq2 slatrz dlatrz clatrz zlatrz).each{|n| SUBSTS[n] = {"m" => "lda"}} %w(slaqps dlaqps claqps zlaqps).each{|n| SUBSTS[n] = {"kb" => "nb"}} %w(sstevx dstevx sstein dstein cstein zstein).each{|n| SUBSTS[n] = {"m" => "n"}} %w(sopgtr dopgtr cupgtr zupgtr).each{|n| SUBSTS[n] = {"n" => "ldtau+1"}} %w(stgsna dtgsna ctgsna ztgsna strsna dtrsna ctrsna ztrsna).each{|n| SUBSTS[n] = {"mm" => "m"}} %w(sggsvd dggsvd cggsvd zggsvd).each{|n| SUBSTS[n] = {"m" => "lda", "p" => "ldb"}} SUBSTS["dlansp"] = {"lwork" => '(lsame_(&norm,"I") || lsame_(&norm,"1") || lsame_(&norm,"0")) ? n : 0'} %w(ssptrd dsptrd chptrd zhptrd sppequ dppequ cppequ zppequ chpevd zhpevd sspev dspev sspevd dspevd chpev zhpev sspgv chpgvx zhpgvx dspgv sspgvd dspgvd chpgv zhpgv chpgvd zhpgvd chptrf zhptrf ssptrf dsptrf csptrf zsptrf stpcon dtpcon ctpcon ztpcon sppcon dppcon cppcon zppcon).each{|n| SUBSTS[n] = {"n" => '(int)(sqrt((double)8*ldap+1)-1)/2'}} %w(sspgvx dspgvx sspevx dspevx chpevx zhpevx).each{|n| SUBSTS[n] = {"n" => '((int)sqrtf(ldap*8+1.0f)-1)/2', "m" => 'lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0'}} %w(sstevr dstevr ssyevr dsyevr dsyevx ssyevx).each{|n| SUBSTS[n] = {"m" => 'lsame_(&range,"I") ? iu-il+1 : n'}} %w(ssygvx dsygvx cheevr zheevr chbevx zhbevx sstemr dstemr cstemr zstemr sstegr dstegr cstegr zstegr ssbevx dsbevx cheevx zheevx chegvx zhegvx ssbgvx dsbgvx).each{|n| SUBSTS[n] = {"m" => 'lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0'}} %w(stgex2 dtgex2).each{|n| SUBSTS[n] = {"lwork" => 'MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)))'}} %w(zlange zlanhs).each{|n| SUBSTS[n] = {"lwork" => 'lsame_(&norm,"I") ? n : 0'}} %w(spprfs dpprfs cpprfs zpprfs chpsv zhpsv sspsv dspsv cspsv zspsv stprfs dtprfs ctprfs ztprfs).each{|n| SUBSTS[n] = {"n" => 'ldb'}} SUBSTS["slasd0"] = {"m" => "sqre == 0 ? n : sqre == 1 ? n+1 : 0", "ldu" => "n", "ldvt" => "m"} SUBSTS["dlasd0"] = {"m" => "sqre == 0 ? n : sqre == 1 ? n+1 : 0", "ldu" => "n", "ldvt" => "n"} SUBSTS["slasd3"] = {"ldu2" => "n", "n" => "nl + nr + 1", "ldvt2" => "n", "m" => "n+sqre"} SUBSTS["dlasd3"] = {"ldu2" => "n", "n" => "nl + nr + 1", "ldvt2" => "n", "m" => "n + sqre"} %w(slasda dlasda).each{|n| SUBSTS[n] = {"m" => "sqre == 0 ? n : sqre == 1 ? n+1 : 0", "ldu" => "n"}} %w(slals0 dlals0 clals0 zlals0 slalsa dlalsa clalsa zlalsa).each{|n| SUBSTS[n] = {"ldbx" => "n"}} %w(slasd2 dlasd2).each{|n| SUBSTS[n] = {"ldu2" => "n", "ldvt2" => "m"}} %w(slasd6 dlasd6).each{|n| SUBSTS[n] = {"m" => "n + sqre", "n" => "nl + nr + 1"}} SUBSTS["dgesdd"] = {"ldvt" => '(lsame_(&jobz,"A")||(lsame_(&jobz,"O")&&(m>=n))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 0'} SUBSTS["zlaqr4"] = {"ldz" => 'wantz ? MAX(1,ihiz) : 1'} %w(slaqr5 dlaqr5).each{|n| SUBSTS[n] = {"ldz" => 'n'}} %w(sgelsd dgelsd).each{|n| SUBSTS[n] = {"c__0" => "0", "c__9" => "9", "smlsiz" => 'ilaenv_(&c__9,"'+n.upcase+'"," ",&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))'}} %w(cgelsd zgelsd).each{|n| SUBSTS[n] = {"c__9" => "9", "c__0" => "0", "smlsiz" => 'ilaenv_(&c__9,"'+n.upcase+'"," ",&c__0,&c__0,&c__0,&c__0)', "nlvl" => 'MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)))', "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)', "liwork" => 'MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)))'}} %w(sormbr dormbr cunmbr zunmbr).each{|n| SUBSTS[n] = {"nq" => 'lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0'}} %w(sbdsdc dbdsdc).each{|n| SUBSTS[n] = {"c__0" => "0", "c__9" => "9", "smlsiz" => 'ilaenv_(&c__9, "'+n.upcase+'", " ", &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', "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'}} %w(clalsd zlalsd).each{|n| SUBSTS[n] = {"nlvl" => '( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1'}} %w(claed8 zlaed8).each{|n| SUBSTS[n] = {"ldq2" => "n"}} def pow(str) str = str.gsub(/([A-Z\d]+?)\*\*([A-Z\d]+)/, 'pow(\\1,\\2)') str = str.gsub(/\(([^\)]+)\)\*\*([A-Z\d]+)/, 'pow(\\1,\\2)') str.gsub!(/lg (\w+)/, 'LG(\\1)') str.gsub!(/(\w) (LG\()/, '\\1*\\2') return str end def get_vname(str) v = pow(str).strip.downcase.gsub(/lg\(/,"LG(").gsub(/([^a-z])max/,'\\1MAX').gsub(/^max/,'MAX').gsub(/min/,"MIN") if /if / =~ v || (/\,/ =~ v && /(MIN|MAX|pow)\(/ !~ v) || / the / =~ v raise "vname is invalid #{v}" end v end def get_dims(str) if /^\((.*)\)\.?$/ =~ str str = $1.strip end if /(max|min)/i =~ str dims = Array.new while (str && str != "") if /^((((MAX|MIN)\s*\([^\,]+\,)|[^\,])+)\,?(.*)$/i =~ str dns = $1.strip str = $5.strip dims.push dns next else /^([^\,]+)(\,.*)$/ =~ str dims.push $1 str = $2.strip end if /^\,(.*)/ =~ str str = $1.strip end end else dims = str.split(",").collect{|dim| dim.sub(/\.$/,"")} end dims.collect do |dim| dim.sub!(/;\Z/,"") if /\A\((.+)\)\Z/ =~ dim dim = $1 end get_vname(dim) end end AO = {"and"=>"&&","or"=>"||"} def get_cond(cond,v=nil) cond.sub!(/\.$/,"") if /^(.+?)\s*(and|or)\s*(.+)$/ =~ cond c0 = $1.strip ao = $2 c1 = $3.strip if /^([A-Z\d]+)\s*=/ =~ c0 v = get_vname($1) else v = nil end cond = "((#{get_cond(c0,v)}) #{AO[ao]} (#{get_cond(c1,v)}))" elsif /^(.+?)\s*=\s*\'(.+)'$/ =~ cond cond = "lsame_(&#{$1.downcase},\"#{$2}\")" else if /=.*=/ =~ cond conds = cond.split("=").collect{|c| c.strip.downcase} cond = Array.new (conds.length-1).times{|i| cond.push "(#{conds[i]}==#{conds[i+1]})" } cond = cond.join("&&") elsif v && (/^\'(.+)\'$/ =~ cond) cond = "lsame_(&#{v},\"#{$1}\")" elsif v && (/^\d+$/ =~ cond) cond = "#{v} == #{cond}" else cond = cond.gsub(/=/,"==").downcase end end cond end def read_file(fname) flag_sub = false subr = nil sub_type = nil flag_pur = false purpose = nil flag_arg = false args = nil flag_fd = false fd = nil File.foreach(fname){|line| if /This routine is not for general use\./ =~ line return nil end if /^\*\s+\.\. Parameters \.\./ =~ line || /^\*\s+\.\. Executable Statements \.\./ =~ line break end if flag_sub if (/^ \$\s* (.+)$/ =~ line) || (/^ \+\s* (.+)$/ =~ line) || (/^ \&\s* (.+)$/ =~ line) subr << " " << $1.chomp else flag_sub = false end next elsif /^ SUBROUTINE/ =~ line subr = line.chomp flag_sub = true next elsif /^ RECURSIVE SUBROUTINE/ =~ line subr = line.chomp flag_sub = true next elsif /^ ([A-Z\s\d\*]+)\s+FUNCTION/ =~ line subr = line.chomp flag_sub = true elsif /^ FUNCTION/ =~ line && /^[sd]laneg/ =~ File.basename(fname) subr = line.chomp flag_sub = true end if flag_pur if /^\*\s+Arguments$/ =~ line flag_pur = false args = line flag_arg = true next else case File.basename(fname) when /^[cz]la_lin_berr/ if /^\* N \(input\) INTEGER$/ =~ line flag_pur = false args = line flag_arg = true next end when /^[sdcz]laqr1/ if /^\* N \(input\) integer$/ =~ line flag_pur = false args = line flag_arg = true next end when /^[sdcz]laqr2/, /^[sdcz]laqr3/ if /^\* WANTT \(input\) LOGICAL$/ =~ line flag_pur = false args = line flag_arg = true next end when /^[sdcz]laqr5/ if /^\* WANTT \(input\) logical scalar$/ =~ line flag_pur = false args = line flag_arg = true next end when /^[sd]lasq4/, /^[sd]lazq4/ if /^\* I0 \(input\) INTEGER$/ =~ line flag_pur = false args = line flag_arg = true next end end purpose << line next end elsif /^\*\s+Purpose$/ =~ line purpose = line flag_pur = true next else case File.basename(fname) when /^[sdcz]laqr1/ if /^\* Given a 2-by-2 or 3-by-3 matrix H, [SDCZ]LAQR1 sets v to a$/ =~ line purpose = line flag_pur = true end when /^[sdcz]laqr2/ if /^\* This subroutine is identical to [SDCZ]LAQR3 except that it avoids$/ =~ line purpose = line flag_pur = true end when /^[sdcz]laqr3/ if /^\* Aggressive early deflation:$/ =~ line purpose = line flag_pur = true end when /^[sdcz]laqr5/ if /^\* This auxiliary subroutine called by [SDCZ]LAQR0 performs a$/ =~ line purpose = line flag_pur = true end end end if flag_arg if /^\*\s+Further Details$/ =~ line || /^\*\s+={40,}$/ =~ line flag_arg = false fd = line flag_fd = true next else args << line next end end if flag_fd fd << line next end } unless subr raise "subr not found #{fname}" end unless purpose raise "purpose not found #{fname}" end unless args raise "args not found #{fname}" end help = subr + "\n\n" + purpose + "\n" + args help << "\n" + fd if fd return {:subr => subr, :purpose => purpose, :args => args, :help => help} end def parse_file(fname, debug) hash = read_file(fname) subr = hash[:subr] purpose = hash[:purpose] args = hash[:args] help = hash[:help] if /^ (?:RECURSIVE )?SUBROUTINE\s+([A-Z\d_]+)\s*\(([^\)]+)\)/ =~ subr sub_name = $1.downcase arg_names = $2 sub_type = :subroutine elsif /^ ([A-Z\s\*\d]+[A-Z\d])\s+FUNCTION\s+([A-Z\d_]+)\s*\(([^\)]+)\)/ =~ subr f_type = $1.strip sub_name = $2.downcase arg_names = $3 sub_type = :function if f_type == "CHARACTER*1" f_type = "CHARACTER" end func_type = CTYPES[f_type] unless func_type raise "func_type #{f_type} is not defined" end elsif /^ FUNCTION\s+([A-Z\d]+)\(([^\)]+)\)/ =~ subr sub_name = $1.downcase arg_names = $2 sub_type = :function case File.basename(fname) when /^[sd]laneg/ func_type = "integer" else raise "function name is invalid #{subr}" end else raise "subroutine or function name is invalid #{subr}" end arg_names = arg_names.split(",").collect{|arg| arg.strip.downcase} unless arg_names raise "arg_names is nil #{fname}" end if debug p sub_name p arg_names end flag = false flag1 = false ary = Array.new args.each{|line| case line when /^\*\s*$/, /^\* Arguments$/, /^\* =========$/ flag = false flag1 = false next end if /^\*\s+([A-Z_\d,\s]+)\s+\((input|output|workspace|in|external procedure)[^\)]*\)\s+([A-Za-z]+)/ =~ line name = $1 intent = $2 type = $3 name.strip! ary.push line.chomp if /array/i =~ line flag = true elsif (/^LD/=~name || /L.*WORK/=~name) && /input/=~intent && /INTEGER/i=~type flag1 = true end elsif flag line.sub!(/^\*\s*/,"") if /[Ii]f / =~ line || /where / =~ line || /^[a-z]/ =~ line || /[a-z]$/ =~ ary[-1] || /is not referenced/ =~ line || /dimension (of [A-Z\d]+ must be )?at least/ =~ ary[-1] || /^Otherwise, / =~ line if /^[^\s]+ is the/ =~ line || /^If [^\.]+ must contain/ =~ line || /where in / =~ line || /At each / =~ line || /^[^\.]+\, [A-Z\d]+ contains / =~ line || /[A-Z]+\(\d\) and [A-Z]+\(\d\) contain the/ =~ line flag = false next end if /^\( lg\(\s*\w?\s*\) = smallest integer \w$/ =~ line || /^such that 2\^\w \>= \w \)$/ =~ line next end while /^(.*)On exit/ =~ line || /^(.*?)[^\.]+ on exit/ =~ line || /^(.*)On entry/ =~ line || /^(.*)The/ =~ line || /^(.*?)[^\.]+ the [^d]/=~ line || /^(.*?)[^\.]+ is an /=~ line line = $1.strip flag = false end if line != "" if /^[A-Z]/ =~ line && /[\.\,;]$/ !~ ary[-1] && /if$/ !~ ary[-1] ary[-1] << ";" end if /\)$/ =~ ary[-1] && /^\(/ =~ line ary[-1] << ";" end ary[-1] << " " << line.chomp end elsif /^(?:The d|D)imension must be at least (.*)$/ =~ line dim = $1 ary[-1].sub!(/\.$/," ") ary[-1] << "(#{dim})" flag = false else flag = false end elsif flag1 line.sub!(/^\*\s*/,"") ary[-1] << " " << line.chomp else if /^\*\s+If L.?WORK = -1, .*a workspace query/ =~ line line.sub!(/^\*\s*/,"") ary[-1] << " " << line.chomp flag1 = true end end } if debug pp ary end args = Hash.new subst = SUBSTS[sub_name] || Hash.new ary.each{|line| line.strip! /^\*\s+([A-Z\d_,\s]+)\s+\(([^\)]+)\)\s*(.*)$/ =~ line name = $1.downcase.strip intent = $2 type = $3.sub(/\.$/,"") hash = Hash.new intent = "input" if intent == "in" intent = "input or input/output" if intent == "input or input/ouptut" case sub_name when /^[cz]larcm$/ case name when "c" intent = "output" end when /^[cz]lacrm$/ case name when "c" intent = "output" end end hash[:intent] = intent if /^l.*work/ =~ name && (/The (dimension|length)? of (the )?(array|work|WORK)/ =~ type || /The amount of workspace available/ =~ type) if (/^(.*?) The (?:dimension|length)? of (?:the )?array\s+(?:WORK\.\s*)?(.+)/ =~ type) || (/^(.*?) The (?:dimension|length)? of (?:the )?(?:array|work|WORK)\.?\s+(.+)/ =~ type) type = $1.strip str = $2 elsif /^(.+?) The amount of workspace available/ =~ type type = $1.strip str = nil else raise "invalid: #{type}, #{name}, #{sub_name}" end aname = name.sub(/^l/,"") fff = false if (/If #{name.upcase} = -1, (then )?.*a workspace query/ =~ str) || (/If #{name.upcase} = -1 .+? returns the optimal/ =~ str) fff = true elsif /^([cz]tgsna|[cz]hetrf)$/=~sub_name && name=="lwork" fff = true elsif str unless /^[sd]tgex2$/ =~ sub_name && name == "lwork" warn "invalid #{str} #{name} #{sub_name}" end end if fff unless ar = args[aname] raise "array not found #{aname} #{name} #{sub_name}" end d = ar[:dims] unless d.length == 1 raise "array length is not 1 #{aname} #{name} #{sub_name}" end if /^[a-z\d_]+$/ =~ d[0] d[0] = "MAX(1,#{d[0]})" end end elsif /^ld/ =~ name && (/(leading|first) dimension of/ =~ type || /(Leading|First) dimension of/ =~ type) if /^([^,]+) T[Hh]e (?:leading|first) dimension of\s+(?:(?:the )?vector)?(?:the array(?:s)?)?\s*(.+)$/ =~ type || /^(.+?) LD[A-Z]+ is the leading dimension of\s+(.+)$/ =~ type || /^(.+?) On entry, (?:LD[A-Z]+\s+specifies the )?(?:leading|first) dimension of (.+)$/ =~ type || /^([^,]+) (?:[Ll]eading|First) dimension of\s+(.+)$/ =~ type type = $1.strip str = $2.strip elsif /^([^,]+)\,\s+(.+?)\s+The (?:leading|first) dimension of\s+(.+)$/ =~ type type = $1.strip str0 = $2.strip str1 = $3.strip str = str1 + ", " + str0 else raise "invalid #{type}, #{name} #{sub_name}" end if /^(?:the )?arrays (.+?),? and ([A-Z\d_]+)[\,\.]?\s*(.*)$/ =~ str anames = $1.strip aname1 = $2 str = $3.strip anames = anames.split(",") anames.push aname1 anames.collect!{|an| an.downcase} elsif /^([A-Z\d_]+) and ([A-Z\d_]+)\, must be at least (.*)$/ =~ str anames = [$1.downcase, $2.downcase] str = $3.strip elsif /^(?:the )?(?:array |matrix )?([A-Z\d_]+)\.?\,?\s*(.*)$/ =~ str anames = [$1.strip.downcase] str = $2.strip case sub_name when /^[cz]laqr[23]$/, /^[sd]laqr3$/, /^[sd]laqr2$/ case name when "ldwv" anames = ["wv"] end when /^[sdcz]pbsvx$/, /^[sdcz]gbbrd$/, /^[sdcz]pbequ$/ case name when "ldab" anames = ["ab"] end end else raise "error #{str} #{name} #{sub_name}" end ff0 = false ff1 = true anames.each{|an| if (ar = args[an]) ff0 = true if /input/ =~ ar[:intent] ff1 = false break end end } unless ff0 warn "arg not found [#{anames.join(",")}], #{name}, #{sub_name}" end if ff1 && str != "" if anames.length == 1 aname = anames[0] elsif anames.include?(name.sub(/^ld/,"")) aname = name.sub(/^ld/,"") else case sub_name when /^[sd]lasda$/ case name when "ldgcol" aname = "givcol" end when /^[sd]lasd6$/ case name when "ldgnum" aname = "givnum" end end end unless aname raise "cannot select anames [#{anames.join(",")}], #{name}, #{sub_name}" end un = name.upcase str.sub!(/\.$/,"") str.gsub!(/\.GE\./,"=") str.gsub!(/>=/,"=") str.gsub!(/=\s*>/,"=") str.gsub!(/(It )?must be at least/, "") str.gsub!(/#{un}\s*=/," ") str.sub!(/(just )?as declared in the (in the )?calling (subroutine|procedure)\./,"") str.strip if /^([^;]+); if ([^,]+), ([^;]+); if ([^,]+), (.+)$/ =~ str if debug p 100 end v = get_vname($1) cond0 = get_cond($2) v0 = get_vname($3) cond1 = get_cond($4) v1 = get_vname($5) str = "#{cond0} ? #{v0} : #{cond1} ? #{v1} : #{v}" elsif /^If ([^\,]+)\,\s+([^;]+); if ([^\,]+)\,\s+(.*)$/ =~ str || /^If ([^\,]+)\,\s+([^\.]+)\. If ([^\,]+)\,\s+(.*)$/ =~ str if debug p 110 end v0 = get_vname($1) cond0 = get_cond($2) v1 = get_vname($3) cond1 = get_cond($4) str = "#{cond0} ? #{v0} : #{cond1} ? #{v1} : 0" elsif /^([^\,]+)\, and if ([^\,]+)\, (?:then )?(.*)$/ =~ str || /^([^;]+); if ([^\,]+)\, (?:then )?(.*)$/ =~ str if debug p 120 end v0 = get_vname($1) cond1 = get_cond($2) v1 = get_vname($3) str = "#{cond1} ? #{v1} : #{v0}" elsif /^(.+?) if ([^;]+); (.+?) otherwise$/ =~ str if debug p 130 end v0 = get_vname($1) cond0 = get_cond($2) v = get_vname($3) str = "#{cond0} ? #{v0} : #{v}" elsif /^If ([^,]+), then\s+(.+?)\.\s+In any case, (.+)$/ =~ str if debug p 140 end cond0 = get_cond($1) v0 = get_vname($2) v = get_vname($3) str = "#{cond0} ? #{v0} : #{v}" elsif /^([^;]+); and if ([^,]+), (.+)$/ =~ str if debug p 150 end v = get_vname($1) cond0 = get_cond($2) v0 = get_vname($3) str = "#{cond0} ? #{v0} : #{v}" elsif /^(.+?) \.LE\. #{un}$/ =~ str if debug p 160 end str = get_vname($1) elsif /^If ([^,]+), then\s+(.+)$/ =~ str if debug p 170 end cond0 = get_cond($1) v0 = get_vname($2) str = "#{cond0} ? #{v0} : 0" elsif (/^[sd]bdsdc$/ =~ sub_name && /^ld(u|vt)$/ =~ name) if debug p 180 end str = 'lsame_(&compq,"I") ? MAX(1,n) : 0' else if debug p 190 end if /^[sdcz]laqr[23]$/ =~ sub_name && name == "ldwv" str = "nw" end begin str = get_vname(str) rescue warn "error #{str}, #{name}, #{sub_name}" end end if /^[sdcz]larrv$/ =~ sub_name && name == "ldz" str = "n" end subst[name] = str end elsif /^(.*?) array of size (.*)$/ =~ type || /^(.*?) arrays?,?(.*)$/i =~ type type = $1.strip str = $2.strip if /^([A-Z\s]+) work$/ =~ type type = $1.strip end if "CHARACTER(1)" == type type = "CHARACTER" end if /\Alength (.*)\z/ =~ str str = $1 end d = DIMS[sub_name] dims = d[name] if d unless dims str.gsub!(/(#{name}) must be at least\s+/,'\\1 = ') str.gsub!(/must be at least\s+/,"") str.gsub!(/at least\s*/,"") str.gsub!(/dimension ([^\(]+) if/, '(\\1) if') str.gsub!(/dimension \>= /,"") str.gsub!(/the dimension of #{name.upcase}/,"") str.gsub!(/.?\s+dimension is/,"") str.gsub!(/(of )?dimensions?/,"") str.gsub!(/\.GE\.?/,">=") str.gsub!(/\.GT\.?/,">") str.gsub!(/\.LE\.?/,"<=") str.gsub!(/\.LT\.?/,"<") str.gsub!(/\.TRUE\.?/,"TRUE") str.gsub!(/\.FALSE\.?/,"FALSE") str.gsub!(/log_2\s*\(/,"1.0/log(2.0)*log((double)") str.gsub!(/INT\s*\(/,"(int)\(") str.strip! if intent == "input" str.sub!(/\s*if .*$/i, "") end if /(...rfsx|...svxx)/ =~ sub_name && name == "params" str = "" end if /[Ii]f/ =~ str || /where/ =~ str || /when/ =~ str dims = Array.new flag = true str.sub!(/;$/,"") if /^\([^;]+\); (\(.+?\) if [A-Z\d]+ = .+? or \(.+?\) if [A-Z\d]+ = .+)$/ =~ str str = $1 end if debug p name p str end while (str && str!="") if (/^(?:and )?\((.*?)\)\s+if\s+([^\,\;]+)[\,\;]\s+(.*)$/ =~ str) && (dim = $1.strip) && (cond = $2.strip) && (str_tmp = $3.strip) && (/ if .* if / !~ cond) && (/\([^\)]+$/ !~ cond) && (/=/ !~ dim) if debug p 1 end str = str_tmp elsif (/^\(([^;]+?)\)\s+if\s+(.+?)\s+(?:or|and)\s+(\(.*\) if.*)$/ =~ str) || (/^\(([^;]+?)\)\s+if\s+(.+?)\s+(\(.*\)\s+if.*)$/ =~ str) if debug p 2 end dim = $1 cond = $2.strip str = $3.strip elsif /^If ([^\,]+)\,\s+([^;\.]+)[;\.]?(.*)$/ =~ str if debug p 2.5 end cond = $1.strip dim = $2 str = $3.strip elsif /^\((.*?)\)\s+if\s+([^\,]+)\, (\(.*\) otherwise)$/ =~ str if debug p 3 end dim = $1.strip cond = $2.strip str = $3.strip elsif (/^(?:and )?\((.+?)\)\s+if\s+(.*)$/ =~ str) && (dim = $1.strip) && (cond = $2.strip) && (/if/ !~ dim) && (/ if /i !~ cond) && (/^[^\(]+\)/ !~ dim) if debug p 4 end str = nil elsif /\A\((.*)\) when (.*) and/ =~ str dim = $1 cond = $2 str = $' elsif /^(.*?)\s+otherwise$/ =~ str && (dim = $1.strip) && (/ if / !~ dim) if debug p 5 end if cond == "not referenced" dims = dims.collect{|d| d + "0"} else get_dims(dim).each_with_index{|d,i| dims[i] = dims[i] + d } end flag = false break elsif /^\((.+?)\);?\s+If ([A-Z_\d]+ = [^\,]+)\, (then )?#{name.upcase} is not referenced.?$/ =~ str if debug p 6 end dims = get_dims($1) cond = get_cond($2) dims = dims.collect{|dim| "#{cond} ? 0 : #{dim}" } flag = false break elsif /^\((.+?)\); Not referenced if (.*)$/ =~ str if debug p 6.5 end v0 = get_vname($1) cond0 = get_cond($2) dims = ["#{cond0} ? 0 : #{v0}"] flag = false break elsif /\((.+?)\)\, where ([A-Z\d]+) >= ([A-Z\d]+) when ([^;]+); otherwise, #{name.upcase} is not referenced\.?$/ =~ str if debug p 7 end dims = get_dims($1) c0 = $2 c1 = $3 cond = get_cond($4) subst[get_vname(c0)] = "#{cond} ? #{get_vname(c1)} : 0" flag = false break elsif /\((.+)\)[\.\,] where ([A-Z\d]+) = (.+)\.?$/ =~ str if debug p 8 end dims = get_dims($1) c0 = $2 c1 = $3 subst[get_vname(c0)] = get_vname(c1) flag = false break elsif /^(?:and )?(not referenced) if (.+).?$/ =~ str if debug p 9 end dim = $1 cond = $2 str = nil elsif (/^\((.+?)\) where ([A-Z\d_]+) = (.*)$/ =~ str) && (dim = $1) && (c0 = $2) && (c1 = $3) && /=/ !~ c1 dims = get_dims(dim) subst[get_vname(c0)] = get_vname(c1) flag = false break else if /^\((.+?)\) (.+?) = (.+?) (?:when|if) ([^,]+), and (.+?) when (.+)$/ =~ str if debug p 10 end dim = $1 dim1 = $2 unless dim == dim1 raise "error #{name} #{sub_name}" end c0 = $3 cond0 = get_cond($4) c1 = $5 cond1 = get_cond($6) dims = get_dims($1) subst[get_vname(dim)] = "#{cond0} ? #{get_vname(c0)} : #{cond1} ? #{get_vname(c1)} : 0" flag = false break elsif /^\((.+?)\) (.+?) = (.+?) (?:when|if) ([^,]+), and (.+?) otherwise.?$/ =~ str if debug p 11 end dim = $1 dim1 = $2 unless dim == dim1 raise "error #{name} #{sub_name}" end c0 = $3 cond0 = get_cond($4) c1 = $5 dims = get_dims(dim) subst[get_vname(dim)] = "#{cond0} ? #{get_vname(c0)} : #{get_vname(c1)}" flag = false break elsif /^\((.+?)\);\s+[Ii]f ([A-Z_\d]+ = [^\,]+)\, ([A-Z_\d]+) \>?= ([^\.]+)\.\s+Otherwise\, ([A-Z_\d]+) \>?= (.*)$/ =~ str if debug p 14 end dim = $1 cond0 = $2 c00 = $3.downcase c01 = $4.downcase c10 = $5.downcase c11 = $6.downcase unless c00==c10 raise "error #{name} #{sub_name}" end dims = get_dims(dim) cond0 = get_cond(cond0) subst[get_vname(c00)] = "#{cond0} ? #{get_vname(c01)} : #{get_vname(c11)}" flag = false break end if /^\((.+?)\)\.\s+[Ii]f ([A-Z_\d]+ = [^\,]+)\, ([A-Z_\d]+) = ([A-Z_\d]+); if ([A-Z_\d]+ = [^\,]+), ([A-Z_\d]+) = ([A-Z_\d]+)$/ =~ str if debug p 13 end dim = $1 cond0 = $2 c00 = $3.downcase c01 = $4.downcase cond1 = $5 c10 = $6.downcase c11 = $7.downcase elsif /\((.+?)\);? ([A-Z_\d]+) = (.+?) if ([^;]+); ([A-Z_\d]+) = (.+?) if (.+)$/ =~ str if debug p 13 end dim = $1 c00 = $2.downcase c01 = $3.downcase cond0 = $4 c10 = $5.downcase c11 = $6.downcase cond1 = $7 else # raise "error '#{str}' in #{name} (#{fname})" warn "'#{str}' in #{name} (#{fname})" dim = "dummy_" + str end if /dummy_/ =~ dim dims = dim else dims = get_dims(dim) cond0 = get_cond(cond0) cond1 = get_cond(cond1) if c00 == c10 subst[get_vname(c00)] = "#{cond0} ? #{get_vname(c01)} : #{cond1} ? #{get_vname(c11)} : 0" else raise "error #{name} #{sub_name}" end end flag = false break end if flag cond = get_cond(cond) if dim == "not referenced" dims = dims.collect{|d| d + cond + " ? 0 : "} else ds = get_dims(dim) ds.each_with_index{|d,i| dims[i] ||= "" dims[i] << cond + " ? " + d + " : " } end end end dims = dims.collect{|d| d + "0"} if flag else dims = get_dims(str) end dims.each_with_index{|dim,i| if /\?/ =~ dim str = dim aa = Array.new while( /^[^\?]+ \? ([^:]+) : (.+)$/ =~ str ) aa.push $1 str = $2 end aa.push str if aa.length > 2 aa = aa.uniq if aa.length == 1 || (aa.length == 2 && aa[-1] == "0") dims[i] = aa[0] end elsif aa.length == 2 if aa.uniq.length == 1 dims[i] = aa[0] end else raise "error [#{aa.join(",")}] #{dim} #{name} #{sub_name}" end end } end if /^[sd]lasda$/ =~ sub_name && name == "difl" subst["nlvl"].sub!(/\)$/,"") end hash[:dims] = dims elsif (/^(.+) work array$/ =~ type) || (/^(.+) array$/ =~ type) type = $1.strip dims = DIMS[sub_name] && DIMS[sub_name][name] unless dims raise "dimension is not defined (#{name} in #{fname})" end elsif /^CHARACTER\*\s*(\d+)$/ =~ type || /^CHARACTER\*?\((\d+)\)$/ =~ type || /^character string/ =~ type type = "CHARACTER" if $1 && $1 != "1" hash[:dims] = [$1] end elsif /^CHARACTER\*\(\*\)$/ =~ type type = "CHARACTER" hash[:dims] = ["*"] elsif /^(.*)\,\s*#{name}\s*=\s*>/i =~ type type = $1.strip elsif /^(.+?)\s+scalar$/ =~ type type = $1 elsif /^(.+?)\s+with value/ =~ type type = $1 end if (t = TYPES[sub_name]) && (t = t[name]) hash[:type] = t else type.sub!(/ scalar/,"") if /^(.+?) FUNCTION of ([^\s]+) (.+?) arguments?$/ =~ type hash[:block_type] = CTYPES[$1] || raise("error block type is invalid #{$1} #{name} #{sub_name}") hash[:block_arg_num] = {"one"=>1,"two"=>2,"three"=>3}[$2] || raise("error #{$2}") hash[:block_arg_type] = CTYPES[$3] || raise("error block arg type is invalid #{$3} #{name} #{sub_name}") else hash[:type] = CTYPES[type.upcase] unless hash[:type] warn("type (#{type}) is not defined in #{name} (#{fname})") end end end if /,/ =~ name name.split(",").each{|n1| args[n1.strip] = hash.dup } else args[name] = hash end } case sub_name when /^[cz]laqr[04]$/ args["iloz"] = {:type => "integer", :intent => "input"} args["ihiz"] = {:type => "integer", :intent => "input"} end if debug pp args end return {:name => sub_name, :category => sub_type, :type => func_type, :argument_names => arg_names, :arguments => args, :fortran_help => help, :md5sum => get_md5sum(help), :substitutions => subst} end def create_hash(fname, debug) hash = parse_file(fname, debug) if hash.nil? warn "skip #{fname}" return nil end sub_name = hash[:name] arg_names = hash.delete(:argument_names) args = hash.delete(:arguments) args.each do |k,v| case v[:intent] when "input or output", "input or input/output", "input / output", "input/workspace/output", "input/workspace" v[:intent] = "input/output" when "workspace/output" v[:intent] = "output" end end unless sub_name warn "this has no subroutine (#{fname})" return nil end unless arg_names raise "no arg_names (#{fname})" end unless args && !args.empty? raise "no args (#{fname})" end hash[:arguments] = arg_names.map{|name| {name => args[name]} } return hash end def generate_code(fnames, debug) nfnames = fnames.length sub_names = Array.new fnames.each_with_index{|fname,i| print "#{i+1}/#{nfnames}\n" if (i+1)%100==0 hash = read_file(fname) next if hash.nil? help = hash[:help] basename = File.basename(fname, ".f") def_dir = File.join(File.dirname(__FILE__), "defs") def_fname = File.join(def_dir, basename) if File.exists?(def_fname) hash = nil File.open(def_fname){|file| hash = YAML.load(file.read) } md5sum = hash[:md5sum] next if get_md5sum(help) == md5sum && !@@force end hash = create_hash(fname, debug) def hash.each [:name, :md5sum, :category].each do |k| yield(k, self[k]) end if self[:category] == :function yield(:type, self[k]) end [:arguments, :substitutions, :fortran_help].each do |k| yield(k, self[k]) end end p "write #{hash[:name]}" if debug File.open(def_fname, "w") do |file| file.write hash.to_yaml end } end def get_md5sum(src) Digest::MD5.hexdigest(src.sub(/LAPACK routine \(version \d.\d\) --/,"")) end debug = ARGV.delete("--debug") force = ARGV.delete("--force") dname = ARGV[0] || raise("Usage: ruby #$0 path_to_lapack_src") if File.directory?(dname) fnames = Dir[ File.join(dname,"*.f") ] elsif File.file?(dname) fnames = [dname] # @@debug = true end generate_code(fnames, debug) ruby-lapack-1.8.1/ext/000077500000000000000000000000001325016550400145345ustar00rootroot00000000000000ruby-lapack-1.8.1/ext/cbbcsd.c000077500000000000000000000403641325016550400161320ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b11d = NA_PTR_TYPE(rblapack_b11d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b11e = NA_PTR_TYPE(rblapack_b11e, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b12d = NA_PTR_TYPE(rblapack_b12d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b12e = NA_PTR_TYPE(rblapack_b12e, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b21d = NA_PTR_TYPE(rblapack_b21d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b21e = NA_PTR_TYPE(rblapack_b21e, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b22d = NA_PTR_TYPE(rblapack_b22d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b22e = NA_PTR_TYPE(rblapack_b22e, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cbdsqr.c000077500000000000000000000265311325016550400161700ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbbrd.c000077500000000000000000000175551325016550400161430ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbcon.c000077500000000000000000000125551325016550400161460ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cgbequ.c000077500000000000000000000131771325016550400161620ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,m); rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbequb.c000077500000000000000000000137171325016550400163240ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbrfs.c000077500000000000000000000223351325016550400161560ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbrfsx.c000077500000000000000000000563601325016550400163530ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cgbsv.c000077500000000000000000000163421325016550400160150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbsvx.c000077500000000000000000000524231325016550400162050ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbsvxx.c000077500000000000000000000734251325016550400164020ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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]; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cgbtf2.c000077500000000000000000000131451325016550400160560ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbtrf.c000077500000000000000000000131361325016550400161560ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgbtrs.c000077500000000000000000000132021325016550400161650ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgebak.c000077500000000000000000000120321325016550400161150ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgebal.c000077500000000000000000000140021325016550400161150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgebd2.c000077500000000000000000000171661325016550400160440ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, complex*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgebrd.c000077500000000000000000000212611325016550400161330ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, complex*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgecon.c000077500000000000000000000077021325016550400161470ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cgeequ.c000077500000000000000000000117131325016550400161570ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeequb.c000077500000000000000000000125161325016550400163230ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgees.c000077500000000000000000000207301325016550400157730ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeesx.c000077500000000000000000000250001325016550400161560ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeev.c000077500000000000000000000164011325016550400157760ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeevx.c000077500000000000000000000312211325016550400161630ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgegs.c000077500000000000000000000244541325016550400160040ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgegv.c000077500000000000000000000321251325016550400160010ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = 8*n; rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgehd2.c000077500000000000000000000127521325016550400160460ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgehrd.c000077500000000000000000000154521325016550400161460ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgelq2.c000077500000000000000000000102341325016550400160600ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgelqf.c000077500000000000000000000133521325016550400161500ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgels.c000077500000000000000000000211341325016550400160010ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgelsd.c000077500000000000000000000250071325016550400161500ustar00rootroot00000000000000#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 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 transformations 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); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgelss.c000077500000000000000000000202331325016550400161630ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgelsx.c000077500000000000000000000204541325016550400161750ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgelsy.c000077500000000000000000000243251325016550400161770ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeql2.c000077500000000000000000000105061325016550400160620ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqlf.c000077500000000000000000000135551325016550400161550ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqp3.c000077500000000000000000000154671325016550400161020ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqpf.c000077500000000000000000000137041325016550400161550ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqr2.c000077500000000000000000000103241325016550400160660ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqr2p.c000077500000000000000000000103361325016550400162510ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqrf.c000077500000000000000000000133641325016550400161610ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgeqrfp.c000077500000000000000000000133771325016550400163450ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgerfs.c000077500000000000000000000204311325016550400161540ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgerfsx.c000077500000000000000000000524221325016550400163510ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cgerq2.c000077500000000000000000000104141325016550400160660ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgerqf.c000077500000000000000000000135771325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgesc2.c000077500000000000000000000125571325016550400160630ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgesdd.c000077500000000000000000000240011325016550400161310ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgesv.c000077500000000000000000000126531325016550400160210ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgesvd.c000077500000000000000000000234321325016550400161620ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgesvx.c000077500000000000000000000500621325016550400162050ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = 2*n; rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgesvxx.c000077500000000000000000000716561325016550400164110ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cgetc2.c000077500000000000000000000106171325016550400160570ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray); } jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgetf2.c000077500000000000000000000101431325016550400160540ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgetrf.c000077500000000000000000000101511325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgetri.c000077500000000000000000000121121325016550400161550ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgetrs.c000077500000000000000000000117211325016550400161740ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggbak.c000077500000000000000000000147221325016550400161270ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggbal.c000077500000000000000000000173261325016550400161330ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgges.c000077500000000000000000000312141325016550400157740ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggesx.c000077500000000000000000000400101325016550400161560ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, real*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggev.c000077500000000000000000000240221325016550400157760ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = 8*n; rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggevx.c000077500000000000000000000423041325016550400161710ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggglm.c000077500000000000000000000212041325016550400161420ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, complex*); { na_shape_t shape[1]; shape[0] = p; rblapack_y = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } y = NA_PTR_TYPE(rblapack_y, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgghrd.c000077500000000000000000000235471325016550400161540ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgglse.c000077500000000000000000000222541325016550400161540ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggqrf.c000077500000000000000000000231271325016550400161610ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(n,m); rblapack_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, complex*); { na_shape_t shape[1]; shape[0] = MIN(n,p); rblapack_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggrqf.c000077500000000000000000000233411325016550400161570ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, complex*); { na_shape_t shape[1]; shape[0] = MIN(p,n); rblapack_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggsvd.c000077500000000000000000000325041325016550400161640ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cggsvp.c000077500000000000000000000234561325016550400162060ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgtcon.c000077500000000000000000000150531325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cgtrfs.c000077500000000000000000000266351325016550400162070ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgtsv.c000077500000000000000000000152401325016550400160330ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgtsvx.c000077500000000000000000000412531325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgttrf.c000077500000000000000000000147241325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n-2; rblapack_du2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } du2 = NA_PTR_TYPE(rblapack_du2, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgttrs.c000077500000000000000000000164651325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cgtts2.c000077500000000000000000000155041325016550400161160ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbev.c000077500000000000000000000136331325016550400160000ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbevd.c000077500000000000000000000245641325016550400161510ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbevx.c000077500000000000000000000251111325016550400161620ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbgst.c000077500000000000000000000147461325016550400161710ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbgv.c000077500000000000000000000205671325016550400160060ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbgvd.c000077500000000000000000000307061325016550400161460ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbgvx.c000077500000000000000000000306671325016550400162000ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chbtrd.c000077500000000000000000000155401325016550400161560ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/checon.c000077500000000000000000000110771325016550400161500ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cheequb.c000077500000000000000000000102771325016550400163260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cheev.c000077500000000000000000000133721325016550400160030ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cheevd.c000077500000000000000000000232671325016550400161530ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cheevr.c000077500000000000000000000405621325016550400161660ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cheevx.c000077500000000000000000000253321325016550400161720ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chegs2.c000077500000000000000000000121431325016550400160570ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chegst.c000077500000000000000000000121401325016550400161560ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chegv.c000077500000000000000000000206161325016550400160040ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chegvd.c000077500000000000000000000305611325016550400161500ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chegvx.c000077500000000000000000000324771325016550400162040ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cherfs.c000077500000000000000000000214031325016550400161550ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cherfsx.c000077500000000000000000000515531325016550400163560ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/chesv.c000077500000000000000000000200311325016550400160070ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chesvx.c000077500000000000000000000334071325016550400162120ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chesvxx.c000077500000000000000000000647601325016550400164100ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/chetd2.c000077500000000000000000000153501325016550400160600ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chetf2.c000077500000000000000000000161501325016550400160610ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chetrd.c000077500000000000000000000172341325016550400161630ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chetrf.c000077500000000000000000000175051325016550400161660ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chetri.c000077500000000000000000000112511325016550400161610ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chetrs.c000077500000000000000000000117501325016550400161770ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chetrs2.c000077500000000000000000000122361325016550400162610ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chfrk.c000077500000000000000000000153411325016550400160040ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chgeqz.c000077500000000000000000000337221325016550400161730ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chla_transtype.c000077500000000000000000000042461325016550400177310ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/chpcon.c000077500000000000000000000107411325016550400161600ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/chpev.c000077500000000000000000000127431325016550400160170ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpevd.c000077500000000000000000000235661325016550400161700ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpevx.c000077500000000000000000000232501325016550400162020ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpgst.c000077500000000000000000000116161325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpgv.c000077500000000000000000000176001325016550400160160ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpgvd.c000077500000000000000000000300471325016550400161620ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpgvx.c000077500000000000000000000304651325016550400162120ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chprfs.c000077500000000000000000000206121325016550400161710ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpsv.c000077500000000000000000000163771325016550400160440ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chpsvx.c000077500000000000000000000316411325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chptrd.c000077500000000000000000000136211325016550400161720ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chptrf.c000077500000000000000000000147351325016550400162030ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chptri.c000077500000000000000000000111131325016550400161710ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chptrs.c000077500000000000000000000116321325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/chsein.c000077500000000000000000000276661325016550400161750ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray); } ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray); } ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/chseqr.c000077500000000000000000000340661325016550400162010ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cla_gbamv.c000077500000000000000000000201471325016550400166220ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gbrcond_c.c000077500000000000000000000207061325016550400174470ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gbrcond_x.c000077500000000000000000000203051325016550400174670ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gbrfsx_extended.c000077500000000000000000000601631325016550400207030ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gbrpvgrw.c000077500000000000000000000120361325016550400173640ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_geamv.c000077500000000000000000000171111325016550400166220ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gercond_c.c000077500000000000000000000171151325016550400174520ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gercond_x.c000077500000000000000000000165541325016550400175050ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_gerfsx_extended.c000077500000000000000000000556041325016550400207120ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_heamv.c000077500000000000000000000164751325016550400166370ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_hercond_c.c000077500000000000000000000166461325016550400174630ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_hercond_x.c000077500000000000000000000162361325016550400175030ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_herfsx_extended.c000077500000000000000000000565341325016550400207160ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_herpvgrw.c000077500000000000000000000140671325016550400173760ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_lin_berr.c000077500000000000000000000113421325016550400173170ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_porcond_c.c000077500000000000000000000153561325016550400175020ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_porcond_x.c000077500000000000000000000147201325016550400175210ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_porfsx_extended.c000077500000000000000000000551721325016550400207350ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_porpvgrw.c000077500000000000000000000121301325016550400174050ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_rpvgrw.c000077500000000000000000000102111325016550400170440ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_syamv.c000077500000000000000000000163761325016550400166760ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_syrcond_c.c000077500000000000000000000166611325016550400175170ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_syrcond_x.c000077500000000000000000000163051325016550400175370ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_syrfsx_extended.c000077500000000000000000000565341325016550400207550ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_syrpvgrw.c000077500000000000000000000141221325016550400174250ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cla_wwaddw.c000077500000000000000000000102751325016550400170240ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/clabrd.c000077500000000000000000000212041325016550400161310ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacgv.c000077500000000000000000000056261325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacn2.c000077500000000000000000000126051325016550400160510ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacon.c000077500000000000000000000101121325016550400161350ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacp2.c000077500000000000000000000070401325016550400160500ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacpy.c000077500000000000000000000070511325016550400161610ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacrm.c000077500000000000000000000076221325016550400161530ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clacrt.c000077500000000000000000000112271325016550400161560ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cladiv.c000077500000000000000000000045621325016550400161540ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/claed0.c000077500000000000000000000154661325016550400160470ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claed7.c000077500000000000000000000361071325016550400160510ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray); } indxq = NA_PTR_TYPE(rblapack_indxq, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claed8.c000077500000000000000000000263511325016550400160520ustar00rootroot00000000000000#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 ); { na_shape_t shape[1]; shape[0] = n; rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dlamda = NA_PTR_TYPE(rblapack_dlamda, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claein.c000077500000000000000000000132211325016550400161350ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claesy.c000077500000000000000000000110611325016550400161620ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/claev2.c000077500000000000000000000100411325016550400160530ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clag2z.c000077500000000000000000000064431325016550400160740ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clags2.c000077500000000000000000000124241325016550400160610ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clagtm.c000077500000000000000000000147401325016550400161600ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clahef.c000077500000000000000000000143021325016550400161250ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clahqr.c000077500000000000000000000213111325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clahr2.c000077500000000000000000000155541325016550400160700ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clahrd.c000077500000000000000000000146241325016550400161470ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claic1.c000077500000000000000000000116261325016550400160450ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clals0.c000077500000000000000000000313171325016550400160660ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clalsa.c000077500000000000000000000404611325016550400161470ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clalsd.c000077500000000000000000000207651325016550400161570ustar00rootroot00000000000000#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; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clangb.c000077500000000000000000000103511325016550400161310ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clange.c000077500000000000000000000075021325016550400161400ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clangt.c000077500000000000000000000106041325016550400161540ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clanhb.c000077500000000000000000000113021325016550400161270ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clanhe.c000077500000000000000000000110441325016550400161350ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clanhf.c000077500000000000000000000223001325016550400161330ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clanhp.c000077500000000000000000000107101325016550400161470ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clanhs.c000077500000000000000000000072361325016550400161630ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clanht.c000077500000000000000000000073651325016550400161670ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clansb.c000077500000000000000000000111511325016550400161440ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clansp.c000077500000000000000000000105141325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clansy.c000077500000000000000000000106651325016550400162040ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clantb.c000077500000000000000000000120241325016550400161450ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clantp.c000077500000000000000000000113221325016550400161630ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clantr.c000077500000000000000000000122351325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clapll.c000077500000000000000000000110231325016550400161470ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clapmr.c000077500000000000000000000103751325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clapmt.c000077500000000000000000000106441325016550400161700ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqgb.c000077500000000000000000000146231325016550400161420ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqge.c000077500000000000000000000132211325016550400161360ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqhb.c000077500000000000000000000123421325016550400161370ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqhe.c000077500000000000000000000122631325016550400161440ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqhp.c000077500000000000000000000116551325016550400161630ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqp2.c000077500000000000000000000172371325016550400160770ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqps.c000077500000000000000000000236271325016550400162000ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = kb; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqr0.c000077500000000000000000000252151325016550400160720ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqr1.c000077500000000000000000000067501325016550400160760ustar00rootroot00000000000000#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)); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqr2.c000077500000000000000000000261641325016550400161000ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } sh = NA_PTR_TYPE(rblapack_sh, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqr3.c000077500000000000000000000256521325016550400161020ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } sh = NA_PTR_TYPE(rblapack_sh, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqr4.c000077500000000000000000000252151325016550400160760ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqr5.c000077500000000000000000000253521325016550400161010ustar00rootroot00000000000000#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; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqsb.c000077500000000000000000000130231325016550400161470ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqsp.c000077500000000000000000000116551325016550400161760ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/claqsy.c000077500000000000000000000122631325016550400162030ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clar1v.c000077500000000000000000000252621325016550400161020ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray); } isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_z_out__ = na_make_object(NA_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); } ruby-lapack-1.8.1/ext/clar2v.c000077500000000000000000000155211325016550400161000ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarcm.c000077500000000000000000000073531325016550400161540ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarf.c000077500000000000000000000116131325016550400157740ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarfb.c000077500000000000000000000150531325016550400161400ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarfg.c000077500000000000000000000103011325016550400161340ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarfgp.c000077500000000000000000000102351325016550400163220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarft.c000077500000000000000000000153651325016550400161700ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarfx.c000077500000000000000000000107021325016550400161620ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clargv.c000077500000000000000000000124051325016550400161630ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarnv.c000077500000000000000000000076241325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarrv.c000077500000000000000000000412261325016550400162010ustar00rootroot00000000000000#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 split.) 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 occurred 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarscl2.c000077500000000000000000000066311325016550400164160ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/clartg.c000077500000000000000000000063511325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/clartv.c000077500000000000000000000133021325016550400161750ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarz.c000077500000000000000000000125421325016550400160220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarzb.c000077500000000000000000000154661325016550400161740ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clarzt.c000077500000000000000000000166051325016550400162120ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clascl.c000077500000000000000000000122161325016550400161460ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clascl2.c000077500000000000000000000065761325016550400162440ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/claset.c000077500000000000000000000103541325016550400161610ustar00rootroot00000000000000#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)); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clasr.c000077500000000000000000000205421325016550400160120ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/classq.c000077500000000000000000000071651325016550400162020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/claswp.c000077500000000000000000000107231325016550400161770ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clasyf.c000077500000000000000000000142701325016550400161700ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatbs.c000077500000000000000000000250111325016550400161520ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatdf.c000077500000000000000000000200641325016550400161420ustar00rootroot00000000000000#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 chosen 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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatps.c000077500000000000000000000241651325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatrd.c000077500000000000000000000174731325016550400161700ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatrs.c000077500000000000000000000247411325016550400162030ustar00rootroot00000000000000#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]; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatrz.c000077500000000000000000000117411325016550400162060ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clatzm.c000077500000000000000000000163141325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/clauu2.c000077500000000000000000000073371325016550400161100ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/clauum.c000077500000000000000000000073351325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbcon.c000077500000000000000000000110211325016550400161420ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cpbequ.c000077500000000000000000000114161325016550400161650ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbrfs.c000077500000000000000000000203701325016550400161640ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbstf.c000077500000000000000000000130421325016550400161640ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbsv.c000077500000000000000000000157731325016550400160350ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbsvx.c000077500000000000000000000401071325016550400162120ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbtf2.c000077500000000000000000000122741325016550400160710ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbtrf.c000077500000000000000000000121271325016550400161660ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpbtrs.c000077500000000000000000000121421325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpftrf.c000077500000000000000000000205631325016550400161750ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpftri.c000077500000000000000000000201301325016550400161660ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpftrs.c000077500000000000000000000204261325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpocon.c000077500000000000000000000076231325016550400161740ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cpoequ.c000077500000000000000000000077571325016550400162170ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpoequb.c000077500000000000000000000077711325016550400163550ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cporfs.c000077500000000000000000000176571325016550400162170ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cporfsx.c000077500000000000000000000500611325016550400163710ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cposv.c000077500000000000000000000134441325016550400160430ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cposvx.c000077500000000000000000000361151325016550400162330ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cposvxx.c000077500000000000000000000624511325016550400164250ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/cpotf2.c000077500000000000000000000100621325016550400160770ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpotrf.c000077500000000000000000000077431325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpotri.c000077500000000000000000000073351325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpotrs.c000077500000000000000000000102071325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cppcon.c000077500000000000000000000100651325016550400161670ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cppequ.c000077500000000000000000000105241325016550400162020ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpprfs.c000077500000000000000000000173101325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cppsv.c000077500000000000000000000143241325016550400160420ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cppsvx.c000077500000000000000000000362551325016550400162410ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpptrf.c000077500000000000000000000105241325016550400162030ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpptri.c000077500000000000000000000073351325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpptrs.c000077500000000000000000000114021325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpstf2.c000077500000000000000000000125261325016550400161120ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpstrf.c000077500000000000000000000125241325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cptcon.c000077500000000000000000000103511325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cpteqr.c000077500000000000000000000164211325016550400162050ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cptrfs.c000077500000000000000000000212141325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cptsv.c000077500000000000000000000135441325016550400160510ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cptsvx.c000077500000000000000000000264011325016550400162350ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpttrf.c000077500000000000000000000103731325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cpttrs.c000077500000000000000000000131041325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cptts2.c000077500000000000000000000122051325016550400161220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/crot.c000077500000000000000000000111651325016550400156560ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cspcon.c000077500000000000000000000107611325016550400161750ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/cspmv.c000077500000000000000000000155731325016550400160460ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cspr.c000077500000000000000000000135051325016550400156560ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csprfs.c000077500000000000000000000206121325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cspsv.c000077500000000000000000000163701325016550400160500ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cspsvx.c000077500000000000000000000316361325016550400162420ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/csptrf.c000077500000000000000000000147621325016550400162160ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csptri.c000077500000000000000000000111131325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csptrs.c000077500000000000000000000116321325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csrscl.c000077500000000000000000000063321325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cstedc.c000077500000000000000000000275141325016550400161610ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cstegr.c000077500000000000000000000302761325016550400162020ustar00rootroot00000000000000#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 compatibility 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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cstein.c000077500000000000000000000204311325016550400161700ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cstemr.c000077500000000000000000000405571325016550400162130ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/csteqr.c000077500000000000000000000152621325016550400162120ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/csycon.c000077500000000000000000000111171325016550400162020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/csyconv.c000077500000000000000000000106361325016550400163750ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/csyequb.c000077500000000000000000000115061325016550400163610ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csymv.c000077500000000000000000000157041325016550400160530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csyr.c000077500000000000000000000131601325016550400156640ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csyrfs.c000077500000000000000000000214031325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csyrfsx.c000077500000000000000000000515531325016550400164150ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/csysv.c000077500000000000000000000203271325016550400160560ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/csysvx.c000077500000000000000000000334071325016550400162510ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/csysvxx.c000077500000000000000000000651661325016550400164500ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/csyswapr.c000077500000000000000000000076711325016550400165710ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytf2.c000077500000000000000000000160261325016550400161220ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytrf.c000077500000000000000000000201421325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytri.c000077500000000000000000000112551325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytri2.c000077500000000000000000000140351325016550400163050ustar00rootroot00000000000000#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); } { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytri2x.c000077500000000000000000000115741325016550400165020ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytrs.c000077500000000000000000000117501325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/csytrs2.c000077500000000000000000000122361325016550400163200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctbcon.c000077500000000000000000000114131325016550400161530ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ctbrfs.c000077500000000000000000000170231325016550400161710ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); work = ALLOC_N(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); } ruby-lapack-1.8.1/ext/ctbtrs.c000077500000000000000000000131671325016550400162140ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctfsm.c000077500000000000000000000264561325016550400160340ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctftri.c000077500000000000000000000205031325016550400161760ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctfttp.c000077500000000000000000000167161325016550400162220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctfttr.c000077500000000000000000000172021325016550400162130ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgevc.c000077500000000000000000000244741325016550400161710ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgex2.c000077500000000000000000000224451325016550400161060ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgexc.c000077500000000000000000000243501325016550400161640ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgsen.c000077500000000000000000000521601325016550400161720ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, complex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, complex*); { na_shape_t shape[1]; shape[0] = 2; rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgsja.c000077500000000000000000000374311325016550400161660ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgsna.c000077500000000000000000000326211325016550400161660ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t shape[1]; shape[0] = mm; rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgsy2.c000077500000000000000000000301441325016550400161200ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctgsyl.c000077500000000000000000000332401325016550400162120ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctpcon.c000077500000000000000000000105541325016550400161760ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ctprfs.c000077500000000000000000000162361325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); work = ALLOC_N(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); } ruby-lapack-1.8.1/ext/ctptri.c000077500000000000000000000107351325016550400162160ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctptrs.c000077500000000000000000000123621325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctpttf.c000077500000000000000000000167251325016550400162220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctpttr.c000077500000000000000000000073721325016550400162340ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrcon.c000077500000000000000000000111121325016550400161670ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ctrevc.c000077500000000000000000000240761325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrexc.c000077500000000000000000000132751325016550400162030ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrrfs.c000077500000000000000000000165221325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); work = ALLOC_N(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); } ruby-lapack-1.8.1/ext/ctrsen.c000077500000000000000000000275021325016550400162070ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrsna.c000077500000000000000000000242771325016550400162110ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrsyl.c000077500000000000000000000142601325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrti2.c000077500000000000000000000100621325016550400161110ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrtri.c000077500000000000000000000101111325016550400162040ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrtrs.c000077500000000000000000000126701325016550400162320ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrttf.c000077500000000000000000000171371325016550400162220ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctrttp.c000077500000000000000000000072761325016550400162370ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctzrqf.c000077500000000000000000000115441325016550400162210ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ctzrzf.c000077500000000000000000000141011325016550400162220ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, complex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunbdb.c000077500000000000000000000345171325016550400161520ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } theta = NA_PTR_TYPE(rblapack_theta, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } phi = NA_PTR_TYPE(rblapack_phi, real*); { na_shape_t shape[1]; shape[0] = p; rblapack_taup1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taup1 = NA_PTR_TYPE(rblapack_taup1, complex*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_taup2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } taup2 = NA_PTR_TYPE(rblapack_taup2, complex*); { na_shape_t shape[1]; shape[0] = q; rblapack_tauq1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tauq1 = NA_PTR_TYPE(rblapack_tauq1, complex*); { na_shape_t shape[1]; shape[0] = m-q; rblapack_tauq2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } tauq2 = NA_PTR_TYPE(rblapack_tauq2, complex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/cuncsd.c000077500000000000000000000311031325016550400161600ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = p; rblapack_u1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } u1 = NA_PTR_TYPE(rblapack_u1, complex*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_u2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } u2 = NA_PTR_TYPE(rblapack_u2, complex*); { na_shape_t shape[1]; shape[0] = q; rblapack_v1t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } v1t = NA_PTR_TYPE(rblapack_v1t, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cung2l.c000077500000000000000000000104141325016550400160750ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cung2r.c000077500000000000000000000104101325016550400160770ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungbr.c000077500000000000000000000155021325016550400161660ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunghr.c000077500000000000000000000126771325016550400162060ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungl2.c000077500000000000000000000102531325016550400160760ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunglq.c000077500000000000000000000124541325016550400162020ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungql.c000077500000000000000000000125111325016550400161740ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungqr.c000077500000000000000000000125051325016550400162050ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungr2.c000077500000000000000000000102731325016550400161060ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungrq.c000077500000000000000000000124731325016550400162110ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cungtr.c000077500000000000000000000124421325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunm2l.c000077500000000000000000000143071325016550400161100ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunm2r.c000077500000000000000000000143101325016550400161100ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmbr.c000077500000000000000000000222651325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmhr.c000077500000000000000000000201261325016550400162000ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunml2.c000077500000000000000000000140771325016550400161140ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmlq.c000077500000000000000000000161251325016550400162070ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmql.c000077500000000000000000000163251325016550400162110ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmqr.c000077500000000000000000000163401325016550400162140ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmr2.c000077500000000000000000000140761325016550400161210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmr3.c000077500000000000000000000157261325016550400161250ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmrq.c000077500000000000000000000161141325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmrz.c000077500000000000000000000170651325016550400162320ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cunmtr.c000077500000000000000000000174741325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, complex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cupgtr.c000077500000000000000000000102611325016550400162070ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/cupmtr.c000077500000000000000000000144701325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dbbcsd.c000077500000000000000000000412471325016550400161340ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b11d = NA_PTR_TYPE(rblapack_b11d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b11e = NA_PTR_TYPE(rblapack_b11e, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b12d = NA_PTR_TYPE(rblapack_b12d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b12e = NA_PTR_TYPE(rblapack_b12e, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b21d = NA_PTR_TYPE(rblapack_b21d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b21e = NA_PTR_TYPE(rblapack_b21e, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b22d = NA_PTR_TYPE(rblapack_b22d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b22e = NA_PTR_TYPE(rblapack_b22e, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dbdsdc.c000077500000000000000000000244411325016550400161330ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dbdsqr.c000077500000000000000000000275411325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ddisna.c000077500000000000000000000106511325016550400161500ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbbrd.c000077500000000000000000000175611325016550400161410ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbcon.c000077500000000000000000000127001325016550400161370ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dgbequ.c000077500000000000000000000134211325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,m); rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbequb.c000077500000000000000000000141231325016550400163150ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbrfs.c000077500000000000000000000226021325016550400161540ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbrfsx.c000077500000000000000000000571371325016550400163570ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dgbsv.c000077500000000000000000000164111325016550400160130ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbsvx.c000077500000000000000000000525571325016550400162160ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = 3*n; rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbsvxx.c000077500000000000000000000741401325016550400163760ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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]; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dgbtf2.c000077500000000000000000000131671325016550400160630ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbtrf.c000077500000000000000000000131601325016550400161540ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgbtrs.c000077500000000000000000000132251325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgebak.c000077500000000000000000000121121325016550400161150ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgebal.c000077500000000000000000000140641325016550400161260ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgebd2.c000077500000000000000000000173771325016550400160510ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgebrd.c000077500000000000000000000214701325016550400161360ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgecon.c000077500000000000000000000100211325016550400161340ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dgeequ.c000077500000000000000000000121351325016550400161570ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgeequb.c000077500000000000000000000127401325016550400163230ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgees.c000077500000000000000000000234071325016550400160000ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeesx.c000077500000000000000000000322411325016550400161640ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeev.c000077500000000000000000000204231325016550400157760ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeevx.c000077500000000000000000000340361325016550400161730ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgegs.c000077500000000000000000000257131325016550400160040ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgegv.c000077500000000000000000000344001325016550400160000ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgehd2.c000077500000000000000000000130401325016550400160360ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgehrd.c000077500000000000000000000155341325016550400161500ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgejsv.c000077500000000000000000002215331325016550400161730ustar00rootroot00000000000000#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@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); } { na_shape_t shape[1]; shape[0] = n; rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray); } sva = NA_PTR_TYPE(rblapack_sva, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = m+3*n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgelq2.c000077500000000000000000000103031325016550400160560ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgelqf.c000077500000000000000000000134171325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgels.c000077500000000000000000000211741325016550400160060ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgelsd.c000077500000000000000000000236261325016550400161560ustar00rootroot00000000000000#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 transformations 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)); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgelss.c000077500000000000000000000201521325016550400161640ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgelsx.c000077500000000000000000000203541325016550400161750ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgelsy.c000077500000000000000000000242051325016550400161750ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgeql2.c000077500000000000000000000105671325016550400160720ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeqlf.c000077500000000000000000000136341325016550400161540ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeqp3.c000077500000000000000000000153471325016550400161000ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgeqpf.c000077500000000000000000000135511325016550400161560ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgeqr2.c000077500000000000000000000104051325016550400160670ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeqr2p.c000077500000000000000000000104161325016550400162510ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeqrf.c000077500000000000000000000134431325016550400161600ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgeqrfp.c000077500000000000000000000134561325016550400163440ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgerfs.c000077500000000000000000000206761325016550400161700ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgerfsx.c000077500000000000000000000531171325016550400163540ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dgerq2.c000077500000000000000000000104631325016550400160730ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgerqf.c000077500000000000000000000136441325016550400161630ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgesc2.c000077500000000000000000000126311325016550400160550ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgesdd.c000077500000000000000000000235011325016550400161360ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgesv.c000077500000000000000000000127221325016550400160170ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgesvd.c000077500000000000000000000233511325016550400161630ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgesvj.c000077500000000000000000000453021325016550400161710ustar00rootroot00000000000000#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@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*); { na_shape_t shape[1]; shape[0] = n; rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray); } sva = NA_PTR_TYPE(rblapack_sva, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgesvx.c000077500000000000000000000504721325016550400162130ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = 4*n; rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgesvxx.c000077500000000000000000000722551325016550400164060ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dgetc2.c000077500000000000000000000106261325016550400160600ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray); } jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgetf2.c000077500000000000000000000101701325016550400160550ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgetrf.c000077500000000000000000000101761325016550400161630ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgetri.c000077500000000000000000000121571325016550400161670ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dgetrs.c000077500000000000000000000117451325016550400162030ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggbak.c000077500000000000000000000150371325016550400161300ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggbal.c000077500000000000000000000175331325016550400161340ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgges.c000077500000000000000000000334661325016550400160100ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggesx.c000077500000000000000000000433071325016550400161730ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggev.c000077500000000000000000000255401325016550400160050ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggevx.c000077500000000000000000000454231325016550400161770ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggglm.c000077500000000000000000000213631325016550400161510ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublereal*); { na_shape_t shape[1]; shape[0] = p; rblapack_y = na_make_object(NA_DFLOAT, 1, shape, cNArray); } y = NA_PTR_TYPE(rblapack_y, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgghrd.c000077500000000000000000000237471325016550400161570ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgglse.c000077500000000000000000000224401325016550400161520ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggqrf.c000077500000000000000000000232561325016550400161650ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(n,m); rblapack_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, doublereal*); { na_shape_t shape[1]; shape[0] = MIN(n,p); rblapack_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggrqf.c000077500000000000000000000234671325016550400161710ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, doublereal*); { na_shape_t shape[1]; shape[0] = MIN(p,n); rblapack_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggsvd.c000077500000000000000000000326061325016550400161700ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = ldq; shape[1] = n; rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray); } q = NA_PTR_TYPE(rblapack_q, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dggsvp.c000077500000000000000000000235111325016550400161770ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = ldq; shape[1] = n; rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray); } q = NA_PTR_TYPE(rblapack_q, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgsvj0.c000077500000000000000000000277511325016550400161140ustar00rootroot00000000000000#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@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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgsvj1.c000077500000000000000000000320171325016550400161040ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgtcon.c000077500000000000000000000154641325016550400161730ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dgtrfs.c000077500000000000000000000272101325016550400161760ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgtsv.c000077500000000000000000000154061325016550400160400ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgtsvx.c000077500000000000000000000416631325016550400162340ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgttrf.c000077500000000000000000000150401325016550400161750ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n-2; rblapack_du2 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } du2 = NA_PTR_TYPE(rblapack_du2, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgttrs.c000077500000000000000000000165571325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dgtts2.c000077500000000000000000000154671325016550400161270ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dhgeqz.c000077500000000000000000000371321325016550400161730ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dhsein.c000077500000000000000000000342271325016550400161650ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray); } ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray); } ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dhseqr.c000077500000000000000000000361371325016550400162030ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/disnan.c000077500000000000000000000034231325016550400161610ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dla_gbamv.c000077500000000000000000000203361325016550400166230ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_gbrcond.c000077500000000000000000000213501325016550400171420ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_gbrfsx_extended.c000077500000000000000000000604341325016550400207050ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_gbrpvgrw.c000077500000000000000000000115431325016550400173670ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_geamv.c000077500000000000000000000173341325016550400166320ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_gercond.c000077500000000000000000000175321325016550400171540ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_gerfsx_extended.c000077500000000000000000000565071325016550400207160ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_lin_berr.c000077500000000000000000000110511325016550400173150ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_porcond.c000077500000000000000000000160231325016550400171710ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_porfsx_extended.c000077500000000000000000000556761325016550400207470ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_porpvgrw.c000077500000000000000000000116541325016550400174200ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_rpvgrw.c000077500000000000000000000077161325016550400170650ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_syamv.c000077500000000000000000000164741325016550400166760ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_syrcond.c000077500000000000000000000175141325016550400172140ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_syrfsx_extended.c000077500000000000000000000572411325016550400207520ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_syrpvgrw.c000077500000000000000000000136411325016550400174330ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dla_wwaddw.c000077500000000000000000000103651325016550400170250ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dlabad.c000077500000000000000000000053761325016550400161250ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlabrd.c000077500000000000000000000213751325016550400161430ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlacn2.c000077500000000000000000000127771325016550400160640ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlacon.c000077500000000000000000000103041325016550400161410ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlacpy.c000077500000000000000000000071371325016550400161670ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dladiv.c000077500000000000000000000052411325016550400161500ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlae2.c000077500000000000000000000057661325016550400157100ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlaebz.c000077500000000000000000000436071325016550400161560ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed0.c000077500000000000000000000201011325016550400160260ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed1.c000077500000000000000000000204151325016550400160370ustar00rootroot00000000000000#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 occurrence 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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed2.c000077500000000000000000000260521325016550400160430ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_indxc = na_make_object(NA_LINT, 1, shape, cNArray); } indxc = NA_PTR_TYPE(rblapack_indxc, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray); } coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed3.c000077500000000000000000000231601325016550400160410ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[2]; shape[0] = ldq; shape[1] = n; rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray); } q = NA_PTR_TYPE(rblapack_q, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed4.c000077500000000000000000000124541325016550400160460ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed5.c000077500000000000000000000101541325016550400160420ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed6.c000077500000000000000000000122361325016550400160460ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlaed7.c000077500000000000000000000366771325016550400160660ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray); } indxq = NA_PTR_TYPE(rblapack_indxq, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed8.c000077500000000000000000000303031325016550400160430ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaed9.c000077500000000000000000000146251325016550400160550ustar00rootroot00000000000000#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 ); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaeda.c000077500000000000000000000222231325016550400161160ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaein.c000077500000000000000000000172761325016550400161540ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaev2.c000077500000000000000000000073501325016550400160650ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlaexc.c000077500000000000000000000133001325016550400161400ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlag2.c000077500000000000000000000153141325016550400157000ustar00rootroot00000000000000#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 threshold 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* threshold 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); } ruby-lapack-1.8.1/ext/dlag2s.c000077500000000000000000000073101325016550400160600ustar00rootroot00000000000000#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 conversion 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlags2.c000077500000000000000000000112221325016550400160550ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlagtf.c000077500000000000000000000176141325016550400161550ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n-2; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray); } in = NA_PTR_TYPE(rblapack_in, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlagtm.c000077500000000000000000000150701325016550400161560ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlagts.c000077500000000000000000000211741325016550400161660ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlagv2.c000077500000000000000000000155311325016550400160670ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = 2; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = 2; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlahqr.c000077500000000000000000000230351325016550400161610ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlahr2.c000077500000000000000000000156531325016550400160710ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlahrd.c000077500000000000000000000147061325016550400161510ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaic1.c000077500000000000000000000113151325016550400160410ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlaln2.c000077500000000000000000000210211325016550400160530ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlals0.c000077500000000000000000000316311325016550400160660ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlalsa.c000077500000000000000000000411111325016550400161410ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlalsd.c000077500000000000000000000207011325016550400161460ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlamrg.c000077500000000000000000000073071325016550400161600ustar00rootroot00000000000000#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 arguments 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaneg.c000077500000000000000000000112331325016550400161350ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlangb.c000077500000000000000000000105061325016550400161340ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlange.c000077500000000000000000000075671325016550400161540ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlangt.c000077500000000000000000000106671325016550400161660ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlanhs.c000077500000000000000000000073261325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlansb.c000077500000000000000000000112411325016550400161450ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlansf.c000077500000000000000000000173041325016550400161570ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlansp.c000077500000000000000000000106251325016550400161700ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlanst.c000077500000000000000000000074521325016550400162000ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlansy.c000077500000000000000000000107761325016550400162100ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlantb.c000077500000000000000000000121561325016550400161540ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlantp.c000077500000000000000000000114121325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlantr.c000077500000000000000000000123251325016550400161720ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlanv2.c000077500000000000000000000101541325016550400160720ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlapll.c000077500000000000000000000112131325016550400161510ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlapmr.c000077500000000000000000000104221325016550400161610ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlapmt.c000077500000000000000000000106711325016550400161710ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlapy2.c000077500000000000000000000034551325016550400161050ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlapy3.c000077500000000000000000000037211325016550400161020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlaqgb.c000077500000000000000000000150321325016550400161360ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqge.c000077500000000000000000000134301325016550400161410ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlaqp2.c000077500000000000000000000174661325016550400161040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqps.c000077500000000000000000000241031325016550400161670ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = kb; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqr0.c000077500000000000000000000276501325016550400161000ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = ihi; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = ihi; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqr1.c000077500000000000000000000073641325016550400161010ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqr2.c000077500000000000000000000274421325016550400161010ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } sr = NA_PTR_TYPE(rblapack_sr, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_si = na_make_object(NA_DFLOAT, 1, shape, cNArray); } si = NA_PTR_TYPE(rblapack_si, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqr3.c000077500000000000000000000271301325016550400160740ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } sr = NA_PTR_TYPE(rblapack_sr, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_si = na_make_object(NA_DFLOAT, 1, shape, cNArray); } si = NA_PTR_TYPE(rblapack_si, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqr4.c000077500000000000000000000276501325016550400161040ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = ihi; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = ihi; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqr5.c000077500000000000000000000276351325016550400161100ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqsb.c000077500000000000000000000131521325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqsp.c000077500000000000000000000120041325016550400161640ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaqsy.c000077500000000000000000000124121325016550400162000ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlaqtr.c000077500000000000000000000154661325016550400162060ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlar1v.c000077500000000000000000000255461325016550400161100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray); } isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_z_out__ = na_make_object(NA_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); } ruby-lapack-1.8.1/ext/dlar2v.c000077500000000000000000000152611325016550400161020ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarf.c000077500000000000000000000113661325016550400160020ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dlarfb.c000077500000000000000000000151361325016550400161430ustar00rootroot00000000000000#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; { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (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); } ruby-lapack-1.8.1/ext/dlarfg.c000077500000000000000000000075341325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarfgp.c000077500000000000000000000075341325016550400163330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarft.c000077500000000000000000000154451325016550400161700ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarfx.c000077500000000000000000000106031325016550400161630ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dlargv.c000077500000000000000000000115021325016550400161610ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarnv.c000077500000000000000000000073071325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarra.c000077500000000000000000000150011325016550400161450ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray); } isplit = NA_PTR_TYPE(rblapack_isplit, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarrb.c000077500000000000000000000242131325016550400161530ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarrc.c000077500000000000000000000117041325016550400161550ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlarrd.c000077500000000000000000000364501325016550400161630ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } werr = NA_PTR_TYPE(rblapack_werr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray); } iblock = NA_PTR_TYPE(rblapack_iblock, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarre.c000077500000000000000000000344061325016550400161630ustar00rootroot00000000000000#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 occurred 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray); } isplit = NA_PTR_TYPE(rblapack_isplit, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } werr = NA_PTR_TYPE(rblapack_werr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wgap = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray); } iblock = NA_PTR_TYPE(rblapack_iblock, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray); } indexw = NA_PTR_TYPE(rblapack_indexw, integer*); { na_shape_t shape[1]; shape[0] = 2*n; rblapack_gers = na_make_object(NA_DFLOAT, 1, shape, cNArray); } gers = NA_PTR_TYPE(rblapack_gers, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarrf.c000077500000000000000000000234701325016550400161630ustar00rootroot00000000000000#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 split).\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*); { na_shape_t shape[1]; shape[0] = n; rblapack_dplus = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dplus = NA_PTR_TYPE(rblapack_dplus, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_lplus = na_make_object(NA_DFLOAT, 1, shape, cNArray); } lplus = NA_PTR_TYPE(rblapack_lplus, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarrj.c000077500000000000000000000176241325016550400161730ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarrk.c000077500000000000000000000124601325016550400161650ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlarrr.c000077500000000000000000000076111325016550400161760ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarrv.c000077500000000000000000000416341325016550400162050ustar00rootroot00000000000000#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 split.) 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 occurred 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarscl2.c000077500000000000000000000067141325016550400164210ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dlartg.c000077500000000000000000000057111325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlartgp.c000077500000000000000000000055321325016550400163450ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlartgs.c000077500000000000000000000053361325016550400163520ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlartv.c000077500000000000000000000133351325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaruv.c000077500000000000000000000072471325016550400162120ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlarz.c000077500000000000000000000123241325016550400160210ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dlarzb.c000077500000000000000000000155511325016550400161700ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (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); } ruby-lapack-1.8.1/ext/dlarzt.c000077500000000000000000000166651325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlas2.c000077500000000000000000000063241325016550400157150ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlascl.c000077500000000000000000000123041325016550400161450ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlascl2.c000077500000000000000000000066541325016550400162420ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dlasd0.c000077500000000000000000000151071325016550400160560ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd1.c000077500000000000000000000236171325016550400160640ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray); } idxq = NA_PTR_TYPE(rblapack_idxq, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd2.c000077500000000000000000000333631325016550400160640ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray); } z = NA_PTR_TYPE(rblapack_z, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_idxc = na_make_object(NA_LINT, 1, shape, cNArray); } idxc = NA_PTR_TYPE(rblapack_idxc, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray); } coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd3.c000077500000000000000000000264661325016550400160730ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = k; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd4.c000077500000000000000000000132121325016550400160550ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd5.c000077500000000000000000000107351325016550400160650ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd6.c000077500000000000000000000370011325016550400160610ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray); } idxq = NA_PTR_TYPE(rblapack_idxq, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray); } difl = NA_PTR_TYPE(rblapack_difl, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = m; rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray); } z = NA_PTR_TYPE(rblapack_z, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd7.c000077500000000000000000000325241325016550400160670ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = m; rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray); } z = NA_PTR_TYPE(rblapack_z, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasd8.c000077500000000000000000000224761325016550400160750ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = k; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = k; rblapack_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray); } difl = NA_PTR_TYPE(rblapack_difl, doublereal*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasda.c000077500000000000000000000330421325016550400161350ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray); } givptr = NA_PTR_TYPE(rblapack_givptr, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasdq.c000077500000000000000000000260771325016550400161670ustar00rootroot00000000000000#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 whether 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasdt.c000077500000000000000000000067661325016550400161750ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_inode = na_make_object(NA_LINT, 1, shape, cNArray); } inode = NA_PTR_TYPE(rblapack_inode, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_ndiml = na_make_object(NA_LINT, 1, shape, cNArray); } ndiml = NA_PTR_TYPE(rblapack_ndiml, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlaset.c000077500000000000000000000104331325016550400161600ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlasq1.c000077500000000000000000000114521325016550400160730ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasq2.c000077500000000000000000000110051325016550400160660ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasq3.c000077500000000000000000000152631325016550400161010ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlasq4.c000077500000000000000000000112021325016550400160670ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlasq5.c000077500000000000000000000110311325016550400160700ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlasq6.c000077500000000000000000000103561325016550400161020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlasr.c000077500000000000000000000206651325016550400160210ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlasrt.c000077500000000000000000000061531325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlassq.c000077500000000000000000000071741325016550400162030ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlasv2.c000077500000000000000000000107441325016550400161040ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dlaswp.c000077500000000000000000000107501325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlasy2.c000077500000000000000000000156541325016550400161140ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlasyf.c000077500000000000000000000142571325016550400161760ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlat2s.c000077500000000000000000000077231325016550400161050ustar00rootroot00000000000000#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 conversion 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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlatbs.c000077500000000000000000000250671325016550400161660ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlatdf.c000077500000000000000000000201171325016550400161420ustar00rootroot00000000000000#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 chosen 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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlatps.c000077500000000000000000000241621325016550400161770ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlatrd.c000077500000000000000000000176061325016550400161670ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlatrs.c000077500000000000000000000247431325016550400162060ustar00rootroot00000000000000#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]; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlatrz.c000077500000000000000000000120311325016550400162000ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dlatzm.c000077500000000000000000000162431325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dlauu2.c000077500000000000000000000073641325016550400161110ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID dlauu2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info); static VALUE rblapack_dlauu2(int argc, VALUE *argv, VALUE self){ VALUE rblapack_uplo; char uplo; VALUE rblapack_a; doublereal *a; VALUE rblapack_info; integer info; VALUE rblapack_a_out__; doublereal *a_out__; integer lda; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DLAUU2 computes the product U * U' or L' * L, where the triangular\n* factor U or L is stored in the upper or lower triangular part of\n* the array A.\n*\n* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n* overwriting the factor U in A.\n* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n* overwriting the factor L in A.\n*\n* This is the unblocked form of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the triangular factor stored in the array A\n* is upper or lower triangular:\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the triangular factor U or L. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular factor U or L.\n* On exit, if UPLO = 'U', the upper triangle of A is\n* overwritten with the upper triangle of the product U * U';\n* if UPLO = 'L', the lower triangle of A is overwritten with\n* the lower triangle of the product L' * L.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlauu2( uplo, a, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 2 && argc != 2) rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc); rblapack_uplo = argv[0]; rblapack_a = argv[1]; if (argc == 2) { } else if (rblapack_options != Qnil) { } else { } uplo = StringValueCStr(rblapack_uplo)[0]; if (!NA_IsNArray(rblapack_a)) rb_raise(rb_eArgError, "a (2th argument) must be NArray"); if (NA_RANK(rblapack_a) != 2) rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2); lda = NA_SHAPE0(rblapack_a); n = NA_SHAPE1(rblapack_a); if (NA_TYPE(rblapack_a) != NA_DFLOAT) rblapack_a = na_change_type(rblapack_a, NA_DFLOAT); a = NA_PTR_TYPE(rblapack_a, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; dlauu2_(&uplo, &n, a, &lda, &info); rblapack_info = INT2NUM(info); return rb_ary_new3(2, rblapack_info, rblapack_a); } void init_lapack_dlauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "dlauu2", rblapack_dlauu2, -1); } ruby-lapack-1.8.1/ext/dlauum.c000077500000000000000000000073621325016550400162020ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID dlauum_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info); static VALUE rblapack_dlauum(int argc, VALUE *argv, VALUE self){ VALUE rblapack_uplo; char uplo; VALUE rblapack_a; doublereal *a; VALUE rblapack_info; integer info; VALUE rblapack_a_out__; doublereal *a_out__; integer lda; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DLAUUM computes the product U * U' or L' * L, where the triangular\n* factor U or L is stored in the upper or lower triangular part of\n* the array A.\n*\n* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n* overwriting the factor U in A.\n* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n* overwriting the factor L in A.\n*\n* This is the blocked form of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the triangular factor stored in the array A\n* is upper or lower triangular:\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the triangular factor U or L. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular factor U or L.\n* On exit, if UPLO = 'U', the upper triangle of A is\n* overwritten with the upper triangle of the product U * U';\n* if UPLO = 'L', the lower triangle of A is overwritten with\n* the lower triangle of the product L' * L.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlauum( uplo, a, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 2 && argc != 2) rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc); rblapack_uplo = argv[0]; rblapack_a = argv[1]; if (argc == 2) { } else if (rblapack_options != Qnil) { } else { } uplo = StringValueCStr(rblapack_uplo)[0]; if (!NA_IsNArray(rblapack_a)) rb_raise(rb_eArgError, "a (2th argument) must be NArray"); if (NA_RANK(rblapack_a) != 2) rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2); lda = NA_SHAPE0(rblapack_a); n = NA_SHAPE1(rblapack_a); if (NA_TYPE(rblapack_a) != NA_DFLOAT) rblapack_a = na_change_type(rblapack_a, NA_DFLOAT); a = NA_PTR_TYPE(rblapack_a, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; dlauum_(&uplo, &n, a, &lda, &info); rblapack_info = INT2NUM(info); return rb_ary_new3(2, rblapack_info, rblapack_a); } void init_lapack_dlauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "dlauum", rblapack_dlauum, -1); } ruby-lapack-1.8.1/ext/dopgtr.c000077500000000000000000000103621325016550400162040ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID dopgtr_(char* uplo, integer* n, doublereal* ap, doublereal* tau, doublereal* q, integer* ldq, doublereal* work, integer* info); static VALUE rblapack_dopgtr(int argc, VALUE *argv, VALUE self){ VALUE rblapack_uplo; char uplo; VALUE rblapack_ap; doublereal *ap; VALUE rblapack_tau; doublereal *tau; VALUE rblapack_q; doublereal *q; VALUE rblapack_info; integer info; doublereal *work; integer ldap; integer ldtau; integer ldq; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n q, info = NumRu::Lapack.dopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DOPGTR generates a real orthogonal matrix Q which is defined as the\n* product of n-1 elementary reflectors H(i) of order n, as returned by\n* DSPTRD using packed storage:\n*\n* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular packed storage used in previous\n* call to DSPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to DSPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by DSPTRD.\n*\n* TAU (input) DOUBLE PRECISION array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DSPTRD.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* The N-by-N orthogonal matrix Q.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N-1)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n q, info = NumRu::Lapack.dopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 3 && argc != 3) rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc); rblapack_uplo = argv[0]; rblapack_ap = argv[1]; rblapack_tau = argv[2]; if (argc == 3) { } else if (rblapack_options != Qnil) { } else { } uplo = StringValueCStr(rblapack_uplo)[0]; if (!NA_IsNArray(rblapack_tau)) rb_raise(rb_eArgError, "tau (3th argument) must be NArray"); if (NA_RANK(rblapack_tau) != 1) rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1); ldtau = NA_SHAPE0(rblapack_tau); if (NA_TYPE(rblapack_tau) != NA_DFLOAT) rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT); tau = NA_PTR_TYPE(rblapack_tau, doublereal*); n = ldtau+1; if (!NA_IsNArray(rblapack_ap)) rb_raise(rb_eArgError, "ap (2th argument) must be NArray"); if (NA_RANK(rblapack_ap) != 1) rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1); ldap = NA_SHAPE0(rblapack_ap); if (NA_TYPE(rblapack_ap) != NA_DFLOAT) rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT); ap = NA_PTR_TYPE(rblapack_ap, doublereal*); ldq = MAX(1,n); { na_shape_t shape[2]; shape[0] = ldq; shape[1] = n; rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray); } q = NA_PTR_TYPE(rblapack_q, doublereal*); work = ALLOC_N(doublereal, (n-1)); dopgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info); free(work); rblapack_info = INT2NUM(info); return rb_ary_new3(2, rblapack_q, rblapack_info); } void init_lapack_dopgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "dopgtr", rblapack_dopgtr, -1); } ruby-lapack-1.8.1/ext/dopmtr.c000077500000000000000000000145561325016550400162230ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID dopmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublereal* ap, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info); static VALUE rblapack_dopmtr(int argc, VALUE *argv, VALUE self){ VALUE rblapack_side; char side; VALUE rblapack_uplo; char uplo; VALUE rblapack_trans; char trans; VALUE rblapack_m; integer m; VALUE rblapack_ap; doublereal *ap; VALUE rblapack_tau; doublereal *tau; VALUE rblapack_c; doublereal *c; VALUE rblapack_info; integer info; VALUE rblapack_c_out__; doublereal *c_out__; doublereal *work; integer ldc; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DOPMTR overwrites the general real M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'T': Q**T * C C * Q**T\n*\n* where Q is a real orthogonal matrix of order nq, with nq = m if\n* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n* nq-1 elementary reflectors, as returned by DSPTRD using packed\n* storage:\n*\n* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**T from the Left;\n* = 'R': apply Q or Q**T from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular packed storage used in previous\n* call to DSPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to DSPTRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'T': Transpose, apply Q**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix C. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension\n* (M*(M+1)/2) if SIDE = 'L'\n* (N*(N+1)/2) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by DSPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'\n* or (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DSPTRD.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 7 && argc != 7) rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc); rblapack_side = argv[0]; rblapack_uplo = argv[1]; rblapack_trans = argv[2]; rblapack_m = argv[3]; rblapack_ap = argv[4]; rblapack_tau = argv[5]; rblapack_c = argv[6]; if (argc == 7) { } else if (rblapack_options != Qnil) { } else { } side = StringValueCStr(rblapack_side)[0]; trans = StringValueCStr(rblapack_trans)[0]; if (!NA_IsNArray(rblapack_c)) rb_raise(rb_eArgError, "c (7th argument) must be NArray"); if (NA_RANK(rblapack_c) != 2) rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2); ldc = NA_SHAPE0(rblapack_c); n = NA_SHAPE1(rblapack_c); if (NA_TYPE(rblapack_c) != NA_DFLOAT) rblapack_c = na_change_type(rblapack_c, NA_DFLOAT); c = NA_PTR_TYPE(rblapack_c, doublereal*); uplo = StringValueCStr(rblapack_uplo)[0]; m = NUM2INT(rblapack_m); if (!NA_IsNArray(rblapack_tau)) rb_raise(rb_eArgError, "tau (6th argument) must be NArray"); if (NA_RANK(rblapack_tau) != 1) rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1); if (NA_SHAPE0(rblapack_tau) != (m-1)) rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1); if (NA_TYPE(rblapack_tau) != NA_DFLOAT) rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT); tau = NA_PTR_TYPE(rblapack_tau, doublereal*); if (!NA_IsNArray(rblapack_ap)) rb_raise(rb_eArgError, "ap (5th argument) must be NArray"); if (NA_RANK(rblapack_ap) != 1) rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1); if (NA_SHAPE0(rblapack_ap) != (m*(m+1)/2)) rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2); if (NA_TYPE(rblapack_ap) != NA_DFLOAT) rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT); ap = NA_PTR_TYPE(rblapack_ap, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); dopmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info); free(work); rblapack_info = INT2NUM(info); return rb_ary_new3(2, rblapack_info, rblapack_c); } void init_lapack_dopmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "dopmtr", rblapack_dopmtr, -1); } ruby-lapack-1.8.1/ext/dorbdb.c000077500000000000000000000351051325016550400161430ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID dorbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, doublereal* x11, integer* ldx11, doublereal* x12, integer* ldx12, doublereal* x21, integer* ldx21, doublereal* x22, integer* ldx22, doublereal* theta, doublereal* phi, doublereal* taup1, doublereal* taup2, doublereal* tauq1, doublereal* tauq2, doublereal* work, integer* lwork, integer* info); static VALUE rblapack_dorbdb(int argc, VALUE *argv, VALUE self){ VALUE rblapack_trans; char trans; VALUE rblapack_signs; char signs; VALUE rblapack_m; integer m; VALUE rblapack_x11; doublereal *x11; VALUE rblapack_x12; doublereal *x12; VALUE rblapack_x21; doublereal *x21; VALUE rblapack_x22; doublereal *x22; VALUE rblapack_lwork; integer lwork; VALUE rblapack_theta; doublereal *theta; VALUE rblapack_phi; doublereal *phi; VALUE rblapack_taup1; doublereal *taup1; VALUE rblapack_taup2; doublereal *taup2; VALUE rblapack_tauq1; doublereal *tauq1; VALUE rblapack_tauq2; doublereal *tauq2; VALUE rblapack_info; integer info; VALUE rblapack_x11_out__; doublereal *x11_out__; VALUE rblapack_x12_out__; doublereal *x12_out__; VALUE rblapack_x21_out__; doublereal *x21_out__; VALUE rblapack_x22_out__; doublereal *x22_out__; doublereal *work; integer ldx11; integer q; integer ldx12; integer ldx21; integer ldx22; integer p; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORBDB simultaneously bidiagonalizes the blocks of an M-by-M\n* partitioned orthogonal matrix X:\n*\n* [ B11 | B12 0 0 ]\n* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T\n* X = [-----------] = [---------] [----------------] [---------] .\n* [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]\n* [ 0 | 0 0 I ]\n*\n* X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n* not the case, then X must be transposed and/or permuted. This can be\n* done in constant time using the TRANS and SIGNS options. See DORCSD\n* for details.)\n*\n* The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n* (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n* represented implicitly by Householder vectors.\n*\n* B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n* implicitly by angles THETA, PHI.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER\n* = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n* order;\n* otherwise: X, U1, U2, V1T, and V2T are stored in column-\n* major order.\n*\n* SIGNS (input) CHARACTER\n* = 'O': The lower-left block is made nonpositive (the\n* \"other\" convention);\n* otherwise: The upper-right block is made nonpositive (the\n* \"default\" convention).\n*\n* M (input) INTEGER\n* The number of rows and columns in X.\n*\n* P (input) INTEGER\n* The number of rows in X11 and X12. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in X11 and X21. 0 <= Q <=\n* MIN(P,M-P,M-Q).\n*\n* X11 (input/output) DOUBLE PRECISION array, dimension (LDX11,Q)\n* On entry, the top-left block of the orthogonal matrix to be\n* reduced. On exit, the form depends on TRANS:\n* If TRANS = 'N', then\n* the columns of tril(X11) specify reflectors for P1,\n* the rows of triu(X11,1) specify reflectors for Q1;\n* else TRANS = 'T', and\n* the rows of triu(X11) specify reflectors for P1,\n* the columns of tril(X11,-1) specify reflectors for Q1.\n*\n* LDX11 (input) INTEGER\n* The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n* P; else LDX11 >= Q.\n*\n* X12 (input/output) DOUBLE PRECISION array, dimension (LDX12,M-Q)\n* On entry, the top-right block of the orthogonal matrix to\n* be reduced. On exit, the form depends on TRANS:\n* If TRANS = 'N', then\n* the rows of triu(X12) specify the first P reflectors for\n* Q2;\n* else TRANS = 'T', and\n* the columns of tril(X12) specify the first P reflectors\n* for Q2.\n*\n* LDX12 (input) INTEGER\n* The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n* P; else LDX11 >= M-Q.\n*\n* X21 (input/output) DOUBLE PRECISION array, dimension (LDX21,Q)\n* On entry, the bottom-left block of the orthogonal matrix to\n* be reduced. On exit, the form depends on TRANS:\n* If TRANS = 'N', then\n* the columns of tril(X21) specify reflectors for P2;\n* else TRANS = 'T', and\n* the rows of triu(X21) specify reflectors for P2.\n*\n* LDX21 (input) INTEGER\n* The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n* M-P; else LDX21 >= Q.\n*\n* X22 (input/output) DOUBLE PRECISION array, dimension (LDX22,M-Q)\n* On entry, the bottom-right block of the orthogonal matrix to\n* be reduced. On exit, the form depends on TRANS:\n* If TRANS = 'N', then\n* the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n* M-P-Q reflectors for Q2,\n* else TRANS = 'T', and\n* the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n* M-P-Q reflectors for P2.\n*\n* LDX22 (input) INTEGER\n* The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n* M-P; else LDX22 >= M-Q.\n*\n* THETA (output) DOUBLE PRECISION array, dimension (Q)\n* The entries of the bidiagonal blocks B11, B12, B21, B22 can\n* be computed from the angles THETA and PHI. See Further\n* Details.\n*\n* PHI (output) DOUBLE PRECISION array, dimension (Q-1)\n* The entries of the bidiagonal blocks B11, B12, B21, B22 can\n* be computed from the angles THETA and PHI. See Further\n* Details.\n*\n* TAUP1 (output) DOUBLE PRECISION array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) DOUBLE PRECISION array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) DOUBLE PRECISION array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) DOUBLE PRECISION array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= M-Q.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array, and no error\n* message related to LWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The bidiagonal blocks B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n* PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n* lower bidiagonal. Every entry in each bidiagonal band is a product\n* of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n* [1] or DORCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2\n* using DORGQR and DORGLQ.\n*\n* Reference\n* =========\n*\n* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n* Algorithms, 50(1):33-65, 2009.\n*\n* ====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 7 && argc != 8) rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc); rblapack_trans = argv[0]; rblapack_signs = argv[1]; rblapack_m = argv[2]; rblapack_x11 = argv[3]; rblapack_x12 = argv[4]; rblapack_x21 = argv[5]; rblapack_x22 = argv[6]; if (argc == 8) { rblapack_lwork = argv[7]; } else if (rblapack_options != Qnil) { rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork"))); } else { rblapack_lwork = Qnil; } trans = StringValueCStr(rblapack_trans)[0]; m = NUM2INT(rblapack_m); signs = StringValueCStr(rblapack_signs)[0]; if (!NA_IsNArray(rblapack_x11)) rb_raise(rb_eArgError, "x11 (4th argument) must be NArray"); if (NA_RANK(rblapack_x11) != 2) rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2); ldx11 = NA_SHAPE0(rblapack_x11); q = NA_SHAPE1(rblapack_x11); if (NA_TYPE(rblapack_x11) != NA_DFLOAT) rblapack_x11 = na_change_type(rblapack_x11, NA_DFLOAT); x11 = NA_PTR_TYPE(rblapack_x11, doublereal*); p = ldx11; ldx21 = p; if (!NA_IsNArray(rblapack_x21)) rb_raise(rb_eArgError, "x21 (6th argument) must be NArray"); if (NA_RANK(rblapack_x21) != 2) rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2); if (NA_SHAPE0(rblapack_x21) != ldx21) rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p"); if (NA_SHAPE1(rblapack_x21) != q) rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11"); if (NA_TYPE(rblapack_x21) != NA_DFLOAT) rblapack_x21 = na_change_type(rblapack_x21, NA_DFLOAT); x21 = NA_PTR_TYPE(rblapack_x21, doublereal*); if (rblapack_lwork == Qnil) lwork = m-q; else { lwork = NUM2INT(rblapack_lwork); } ldx22 = p; if (!NA_IsNArray(rblapack_x22)) rb_raise(rb_eArgError, "x22 (7th argument) must be NArray"); if (NA_RANK(rblapack_x22) != 2) rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2); if (NA_SHAPE0(rblapack_x22) != ldx22) rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p"); if (NA_SHAPE1(rblapack_x22) != (m-q)) rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q); if (NA_TYPE(rblapack_x22) != NA_DFLOAT) rblapack_x22 = na_change_type(rblapack_x22, NA_DFLOAT); x22 = NA_PTR_TYPE(rblapack_x22, doublereal*); ldx12 = p; if (!NA_IsNArray(rblapack_x12)) rb_raise(rb_eArgError, "x12 (5th argument) must be NArray"); if (NA_RANK(rblapack_x12) != 2) rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2); if (NA_SHAPE0(rblapack_x12) != ldx12) rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p"); if (NA_SHAPE1(rblapack_x12) != (m-q)) rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q); if (NA_TYPE(rblapack_x12) != NA_DFLOAT) rblapack_x12 = na_change_type(rblapack_x12, NA_DFLOAT); x12 = NA_PTR_TYPE(rblapack_x12, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } theta = NA_PTR_TYPE(rblapack_theta, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } phi = NA_PTR_TYPE(rblapack_phi, doublereal*); { na_shape_t shape[1]; shape[0] = p; rblapack_taup1 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taup1 = NA_PTR_TYPE(rblapack_taup1, doublereal*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_taup2 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } taup2 = NA_PTR_TYPE(rblapack_taup2, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_tauq1 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublereal*); { na_shape_t shape[1]; shape[0] = m-q; rblapack_tauq2 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublereal*); { na_shape_t shape[2]; shape[0] = ldx11; shape[1] = q; rblapack_x11_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, doublereal*); MEMCPY(x11_out__, x11, doublereal, NA_TOTAL(rblapack_x11)); rblapack_x11 = rblapack_x11_out__; x11 = x11_out__; { na_shape_t shape[2]; shape[0] = ldx12; shape[1] = m-q; rblapack_x12_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, doublereal*); MEMCPY(x12_out__, x12, doublereal, NA_TOTAL(rblapack_x12)); rblapack_x12 = rblapack_x12_out__; x12 = x12_out__; { na_shape_t shape[2]; shape[0] = ldx21; shape[1] = q; rblapack_x21_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, doublereal*); MEMCPY(x21_out__, x21, doublereal, NA_TOTAL(rblapack_x21)); rblapack_x21 = rblapack_x21_out__; x21 = x21_out__; { na_shape_t shape[2]; shape[0] = ldx22; shape[1] = m-q; rblapack_x22_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, doublereal*); MEMCPY(x22_out__, x22, doublereal, NA_TOTAL(rblapack_x22)); rblapack_x22 = rblapack_x22_out__; x22 = x22_out__; work = ALLOC_N(doublereal, (MAX(1,lwork))); dorbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info); free(work); rblapack_info = INT2NUM(info); return rb_ary_new3(11, rblapack_theta, rblapack_phi, rblapack_taup1, rblapack_taup2, rblapack_tauq1, rblapack_tauq2, rblapack_info, rblapack_x11, rblapack_x12, rblapack_x21, rblapack_x22); } void init_lapack_dorbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "dorbdb", rblapack_dorbdb, -1); } ruby-lapack-1.8.1/ext/dorcsd.c000077500000000000000000000276621325016550400161760ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = p; rblapack_u1 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } u1 = NA_PTR_TYPE(rblapack_u1, doublereal*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_u2 = na_make_object(NA_DFLOAT, 1, shape, cNArray); } u2 = NA_PTR_TYPE(rblapack_u2, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_v1t = na_make_object(NA_DFLOAT, 1, shape, cNArray); } v1t = NA_PTR_TYPE(rblapack_v1t, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dorg2l.c000077500000000000000000000104761325016550400161040ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorg2r.c000077500000000000000000000104721325016550400161060ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgbr.c000077500000000000000000000155711325016550400161730ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorghr.c000077500000000000000000000127651325016550400162030ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgl2.c000077500000000000000000000103321325016550400160730ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorglq.c000077500000000000000000000125301325016550400161740ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgql.c000077500000000000000000000125711325016550400162010ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgqr.c000077500000000000000000000125651325016550400162120ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgr2.c000077500000000000000000000103521325016550400161030ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgrq.c000077500000000000000000000125501325016550400162040ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorgtr.c000077500000000000000000000125461325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dorm2l.c000077500000000000000000000143751325016550400161140ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dorm2r.c000077500000000000000000000143761325016550400161230ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dormbr.c000077500000000000000000000222251325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dormhr.c000077500000000000000000000202131325016550400161740ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dorml2.c000077500000000000000000000141621325016550400161060ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dormlq.c000077500000000000000000000162101325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dormql.c000077500000000000000000000164231325016550400162070ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dormqr.c000077500000000000000000000164241325016550400162160ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dormr2.c000077500000000000000000000141611325016550400161130ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dormr3.c000077500000000000000000000157461325016550400161260ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0)); 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); } ruby-lapack-1.8.1/ext/dormrq.c000077500000000000000000000162071325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dormrz.c000077500000000000000000000171511325016550400162250ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dormtr.c000077500000000000000000000175611325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dpbcon.c000077500000000000000000000111371325016550400161530ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dpbequ.c000077500000000000000000000115511325016550400161660ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbrfs.c000077500000000000000000000206211325016550400161640ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbstf.c000077500000000000000000000127601325016550400161730ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbsv.c000077500000000000000000000160421325016550400160240ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbsvx.c000077500000000000000000000404701325016550400162160ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbtf2.c000077500000000000000000000123041325016550400160640ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbtrf.c000077500000000000000000000121511325016550400161640ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpbtrs.c000077500000000000000000000122051325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpftrf.c000077500000000000000000000171521325016550400161760ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpftri.c000077500000000000000000000165521325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpftrs.c000077500000000000000000000171021325016550400162060ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpocon.c000077500000000000000000000077461325016550400162030ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dpoequ.c000077500000000000000000000101131325016550400161740ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpoequb.c000077500000000000000000000101241325016550400163400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dporfs.c000077500000000000000000000201111325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dporfsx.c000077500000000000000000000505411325016550400163750ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dposv.c000077500000000000000000000135121325016550400160400ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dposvx.c000077500000000000000000000364741325016550400162440ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dposvxx.c000077500000000000000000000627431325016550400164320ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dpotf2.c000077500000000000000000000101041325016550400160750ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dpotrf.c000077500000000000000000000077651325016550400162200ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dpotri.c000077500000000000000000000073571325016550400162200ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dpotrs.c000077500000000000000000000102511325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dppcon.c000077500000000000000000000102071325016550400161660ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dppequ.c000077500000000000000000000106601325016550400162040ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpprfs.c000077500000000000000000000175421325016550400162120ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dppsv.c000077500000000000000000000143711325016550400160450ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dppsvx.c000077500000000000000000000366021325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpptrf.c000077500000000000000000000105371325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpptri.c000077500000000000000000000073571325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpptrs.c000077500000000000000000000114451325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpstf2.c000077500000000000000000000126301325016550400161070ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dpstrf.c000077500000000000000000000126261325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dptcon.c000077500000000000000000000105211325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dpteqr.c000077500000000000000000000166671325016550400162220ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dptrfs.c000077500000000000000000000201761325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dptsv.c000077500000000000000000000136751325016550400160570ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dptsvx.c000077500000000000000000000265461325016550400162500ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpttrf.c000077500000000000000000000104751325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dpttrs.c000077500000000000000000000120461325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dptts2.c000077500000000000000000000111071325016550400161230ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/drscl.c000077500000000000000000000063631325016550400160220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbev.c000077500000000000000000000135371325016550400160170ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbevd.c000077500000000000000000000217531325016550400161620ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbevx.c000077500000000000000000000255531325016550400162100ustar00rootroot00000000000000#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; { na_shape_t shape[2]; shape[0] = ldq; shape[1] = n; rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray); } q = NA_PTR_TYPE(rblapack_q, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbgst.c000077500000000000000000000146441325016550400162020ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbgv.c000077500000000000000000000205221325016550400160110ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbgvd.c000077500000000000000000000262141325016550400161610ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbgvx.c000077500000000000000000000316111325016550400162020ustar00rootroot00000000000000#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; { na_shape_t shape[2]; shape[0] = ldq; shape[1] = n; rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray); } q = NA_PTR_TYPE(rblapack_q, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 7*n; rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = 5*n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[1]; shape[0] = m; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsbtrd.c000077500000000000000000000157271325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsfrk.c000077500000000000000000000147171325016550400160260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsgesv.c000077500000000000000000000201701325016550400161760ustar00rootroot00000000000000#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 successfully 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dspcon.c000077500000000000000000000113201325016550400161660ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dspev.c000077500000000000000000000125771325016550400160400ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspevd.c000077500000000000000000000210541325016550400161720ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspevx.c000077500000000000000000000232411325016550400162160ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspgst.c000077500000000000000000000116561325016550400162200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspgv.c000077500000000000000000000175161325016550400160400ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspgvd.c000077500000000000000000000251571325016550400162040ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspgvx.c000077500000000000000000000306211325016550400162200ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsposv.c000077500000000000000000000202741325016550400162260ustar00rootroot00000000000000#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 successfully 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); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsprfs.c000077500000000000000000000210431325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspsv.c000077500000000000000000000164371325016550400160550ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dspsvx.c000077500000000000000000000321541325016550400162370ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsptrd.c000077500000000000000000000137501325016550400162110ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsptrf.c000077500000000000000000000150001325016550400162010ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsptri.c000077500000000000000000000111571325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsptrs.c000077500000000000000000000116721325016550400162310ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstebz.c000077500000000000000000000267141325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray); } iblock = NA_PTR_TYPE(rblapack_iblock, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstedc.c000077500000000000000000000246241325016550400161610ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstegr.c000077500000000000000000000306401325016550400161760ustar00rootroot00000000000000#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 compatibility 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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstein.c000077500000000000000000000201401325016550400161660ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstemr.c000077500000000000000000000373431325016550400162130ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsteqr.c000077500000000000000000000155071325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsterf.c000077500000000000000000000077151325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstev.c000077500000000000000000000123471325016550400160370ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstevd.c000077500000000000000000000203661325016550400162030ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstevr.c000077500000000000000000000344671325016550400162300ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dstevx.c000077500000000000000000000236751325016550400162350ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsycon.c000077500000000000000000000114561325016550400162110ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dsyconv.c000077500000000000000000000106761325016550400164020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dsyequb.c000077500000000000000000000116641325016550400163670ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsyev.c000077500000000000000000000132261325016550400160410ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsyevd.c000077500000000000000000000206711325016550400162070ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsyevr.c000077500000000000000000000361721325016550400162300ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsyevx.c000077500000000000000000000252571325016550400162400ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsygs2.c000077500000000000000000000122031325016550400161140ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsygst.c000077500000000000000000000122001325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsygv.c000077500000000000000000000204771325016550400160510ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsygvd.c000077500000000000000000000260001325016550400162010ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsygvx.c000077500000000000000000000325301325016550400162320ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsyrfs.c000077500000000000000000000216341325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsyrfsx.c000077500000000000000000000522331325016550400164120ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dsysv.c000077500000000000000000000204151325016550400160550ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsysvx.c000077500000000000000000000336621325016550400162550ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsysvxx.c000077500000000000000000000654531325016550400164500ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/dsyswapr.c000077500000000000000000000077141325016550400165700ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytd2.c000077500000000000000000000154731325016550400161260ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytf2.c000077500000000000000000000163131325016550400161220ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytrd.c000077500000000000000000000174101325016550400162170ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytrf.c000077500000000000000000000201771325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytri.c000077500000000000000000000113151325016550400162220ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytri2.c000077500000000000000000000141011325016550400163000ustar00rootroot00000000000000#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); } { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytri2x.c000077500000000000000000000116431325016550400165000ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dsytrs.c000077500000000000000000000120101325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dsytrs2.c000077500000000000000000000122621325016550400163200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtbcon.c000077500000000000000000000115171325016550400161610ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dtbrfs.c000077500000000000000000000172401325016550400161730ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtbtrs.c000077500000000000000000000132201325016550400162030ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtfsm.c000077500000000000000000000247441325016550400160330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtftri.c000077500000000000000000000172251325016550400162060ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtfttp.c000077500000000000000000000153661325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtfttr.c000077500000000000000000000166521325016550400162240ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgevc.c000077500000000000000000000327041325016550400161650ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgex2.c000077500000000000000000000246761325016550400161170ustar00rootroot00000000000000#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))); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgexc.c000077500000000000000000000256551325016550400161760ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgsen.c000077500000000000000000000551741325016550400162030ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t shape[1]; shape[0] = 2; rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgsja.c000077500000000000000000000400201325016550400161530ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgsna.c000077500000000000000000000414131325016550400161660ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t shape[1]; shape[0] = mm; rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgsy2.c000077500000000000000000000317031325016550400161230ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtgsyl.c000077500000000000000000000337011325016550400162150ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtpcon.c000077500000000000000000000106601325016550400161750ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dtprfs.c000077500000000000000000000164531325016550400162160ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtptri.c000077500000000000000000000107571325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtptrs.c000077500000000000000000000124161325016550400162270ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtpttf.c000077500000000000000000000154071325016550400162170ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtpttr.c000077500000000000000000000074301325016550400162300ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrcon.c000077500000000000000000000112161325016550400161750ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/dtrevc.c000077500000000000000000000254231325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrexc.c000077500000000000000000000147361325016550400162070ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrrfs.c000077500000000000000000000167371325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrsen.c000077500000000000000000000347331325016550400162140ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrsna.c000077500000000000000000000264141325016550400162050ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrsyl.c000077500000000000000000000152631325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*); MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/dtrti2.c000077500000000000000000000101041325016550400161070ustar00rootroot00000000000000#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]; { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dtrtri.c000077500000000000000000000101331325016550400162110ustar00rootroot00000000000000#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]; { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dtrtrs.c000077500000000000000000000127241325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrttf.c000077500000000000000000000163741325016550400162250ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtrttp.c000077500000000000000000000073231325016550400162310ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/dtzrqf.c000077500000000000000000000115771325016550400162300ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dtzrzf.c000077500000000000000000000141741325016550400162350ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*); MEMCPY(a_out__, a, doublereal, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/dzsum1.c000077500000000000000000000053431325016550400161330ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/extconf.rb000077500000000000000000000056051325016550400165400ustar00rootroot00000000000000require "rubygems" require "mkmf" def header_not_found(name) warn < #if UINTPTR_MAX == UINT64_MAX typedef int integer; typedef int logical; #else typedef long int integer; typedef long int logical; #endif typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; #ifdef f2c_i2 typedef short ftnlen; #else #if UINTPTR_MAX == UINT64_MAX typedef int ftnlen; #else typedef long int ftnlen; #endif #endif typedef logical (*L_fp)(); #define VOID void #endif ruby-lapack-1.8.1/ext/icmax1.c000077500000000000000000000056171325016550400160760ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ieeeck.c000077500000000000000000000052631325016550400161360ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaclc.c000077500000000000000000000045711325016550400161410ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaclr.c000077500000000000000000000045771325016550400161660ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/iladiag.c000077500000000000000000000037201325016550400162770ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/iladlc.c000077500000000000000000000046071325016550400161420ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/iladlr.c000077500000000000000000000046041325016550400161560ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaenv.c000077500000000000000000000154121325016550400161640ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaprec.c000077500000000000000000000040411325016550400163210ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaslc.c000077500000000000000000000045511325016550400161570ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaslr.c000077500000000000000000000045461325016550400162020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilatrans.c000077500000000000000000000040431325016550400165210ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilauplo.c000077500000000000000000000037231325016550400163550ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilaver.c000077500000000000000000000045551325016550400161760ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilazlc.c000077500000000000000000000046161325016550400161700ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ilazlr.c000077500000000000000000000046131325016550400162040ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/iparmq.c000077500000000000000000000216411325016550400162000ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/izmax1.c000077500000000000000000000056441325016550400161250ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/lsamen.c000077500000000000000000000050241325016550400161630ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/rb_lapack.c000077500000000000000000007772031325016550400166410ustar00rootroot00000000000000#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); #ifdef USEXBLAS extern void init_lapack_cgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cherfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_chesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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_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); #ifdef USEXBLAS extern void init_lapack_clarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_clascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gbrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gbrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_heamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_hercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_hercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_herfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_herpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_porcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_porcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_syrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_syrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_cla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_cposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_csyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_csysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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_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_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_dlarf(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); #ifdef USEXBLAS extern void init_lapack_dlarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dlascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_gbrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_gercond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_porcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_syrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_dla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dsyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_dsysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_sgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_sgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_sgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_sgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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_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); #ifdef USEXBLAS extern void init_lapack_slarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_slascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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_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_slasr(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); #ifdef USEXBLAS extern void init_lapack_sla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_gbrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_gercond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_porcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_syrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_sla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_sporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_sposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_ssyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_ssysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zherfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zhesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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_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); #ifdef USEXBLAS extern void init_lapack_zlarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zlascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gbrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gbrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_heamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_hercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_hercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_herfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_herpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_porcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_porcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_syrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_syrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif #ifdef USEXBLAS extern void init_lapack_zla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zsyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS extern void init_lapack_zsysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_cgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_cgbsv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_cgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_cgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_cgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_cgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_cherfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_chesv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_chesvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_chesvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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_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); #ifdef USEXBLAS init_lapack_clarscl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_clascl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_cla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gbrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gbrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gercond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gercond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_heamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_hercond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_hercond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_herfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_herpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_porcond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_porcond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_syrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_syrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_cla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_cporfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_cposv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_cposvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_cposvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_csyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_csysv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_csysvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_csysvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_dgbsv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_dgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_dgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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_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_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_dlarf(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); #ifdef USEXBLAS init_lapack_dlarscl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dlascl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_gbrcond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_gercond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_porcond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_syrcond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_dla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dporfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_dposv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_dposvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_dposvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_dsyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_dsysv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_dsysvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_dsysvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_sgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_sgbsv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_sgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_sgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_sgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_sgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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_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); #ifdef USEXBLAS init_lapack_slarscl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_slascl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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_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_slasr(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); #ifdef USEXBLAS init_lapack_sla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_gbrcond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_gercond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_porcond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_syrcond(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_sla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_sporfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_sposv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_sposvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_sposvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_ssyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_ssysv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_ssysvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_ssysvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_zgbsv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_zgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_zgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zherfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_zhesv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_zhesvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_zhesvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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_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); #ifdef USEXBLAS init_lapack_zlarscl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zlascl2(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gbrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gbrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gercond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gercond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_heamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_hercond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_hercond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_herfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_herpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_porcond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_porcond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_syrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_syrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif #ifdef USEXBLAS init_lapack_zla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zporfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_zposv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_zposvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_zposvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); #ifdef USEXBLAS init_lapack_zsyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif init_lapack_zsysv(mLapack, sHelp, sUsage, rblapack_ZERO); init_lapack_zsysvx(mLapack, sHelp, sUsage, rblapack_ZERO); #ifdef USEXBLAS init_lapack_zsysvxx(mLapack, sHelp, sUsage, rblapack_ZERO); #endif 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); } ruby-lapack-1.8.1/ext/rb_lapack.h000077500000000000000000000011511325016550400166240ustar00rootroot00000000000000#include #include #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); 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; /* for compatibility for NArray and NArray with bigmem patch */ #ifndef NARRAY_BIGMEM typedef int na_shape_t; #endif ruby-lapack-1.8.1/ext/sbbcsd.c000077500000000000000000000402571325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b11d = NA_PTR_TYPE(rblapack_b11d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b11e = NA_PTR_TYPE(rblapack_b11e, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b12d = NA_PTR_TYPE(rblapack_b12d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b12e = NA_PTR_TYPE(rblapack_b12e, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b21d = NA_PTR_TYPE(rblapack_b21d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b21e = NA_PTR_TYPE(rblapack_b21e, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b22d = NA_PTR_TYPE(rblapack_b22d, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } b22e = NA_PTR_TYPE(rblapack_b22e, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sbdsdc.c000077500000000000000000000242261325016550400161530ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sbdsqr.c000077500000000000000000000271121325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/scsum1.c000077500000000000000000000053021325016550400161160ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sdisna.c000077500000000000000000000105551325016550400161720ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbbrd.c000077500000000000000000000171731325016550400161570ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbcon.c000077500000000000000000000125321325016550400161610ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sgbequ.c000077500000000000000000000131571325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,m); rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbequb.c000077500000000000000000000137171325016550400163440ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbrfs.c000077500000000000000000000222361325016550400161760ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbrfsx.c000077500000000000000000000563541325016550400163760ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sgbsv.c000077500000000000000000000162511325016550400160340ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbsvx.c000077500000000000000000000522371325016550400162300ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = 3*n; rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbsvxx.c000077500000000000000000000734161325016550400164220ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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]; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sgbtf2.c000077500000000000000000000131071325016550400160740ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbtrf.c000077500000000000000000000131001325016550400161650ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgbtrs.c000077500000000000000000000131071325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgebak.c000077500000000000000000000117741325016550400161510ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgebal.c000077500000000000000000000137461325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgebd2.c000077500000000000000000000170711325016550400160570ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, real*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgebrd.c000077500000000000000000000211631325016550400161540ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, real*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgecon.c000077500000000000000000000076531325016550400161740ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sgeequ.c000077500000000000000000000116731325016550400162040ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeequb.c000077500000000000000000000124761325016550400163500ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgees.c000077500000000000000000000231071325016550400160140ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgeesx.c000077500000000000000000000316611325016550400162100ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeev.c000077500000000000000000000201151325016550400160130ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgeevx.c000077500000000000000000000333471325016550400162160ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgegs.c000077500000000000000000000252731325016550400160240ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgegv.c000077500000000000000000000337541325016550400160320ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgehd2.c000077500000000000000000000126641325016550400160700ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgehrd.c000077500000000000000000000153601325016550400161640ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgejsv.c000077500000000000000000002211731325016550400162120ustar00rootroot00000000000000#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@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); } { na_shape_t shape[1]; shape[0] = n; rblapack_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray); } sva = NA_PTR_TYPE(rblapack_sva, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = m+3*n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgelq2.c000077500000000000000000000101271325016550400161010ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgelqf.c000077500000000000000000000132431325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgels.c000077500000000000000000000210121325016550400160140ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgelsd.c000077500000000000000000000235011325016550400161650ustar00rootroot00000000000000#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 transformations 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)); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgelss.c000077500000000000000000000177021325016550400162120ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgelsx.c000077500000000000000000000201351325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgelsy.c000077500000000000000000000237731325016550400162250ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeql2.c000077500000000000000000000104131325016550400160770ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeqlf.c000077500000000000000000000134601325016550400161700ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgeqp3.c000077500000000000000000000151731325016550400161140ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeqpf.c000077500000000000000000000133751325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeqr2.c000077500000000000000000000102311325016550400161030ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeqr2p.c000077500000000000000000000102431325016550400162660ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgeqrf.c000077500000000000000000000132701325016550400161750ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgeqrfp.c000077500000000000000000000133031325016550400163520ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgerfs.c000077500000000000000000000203321325016550400161740ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgerfsx.c000077500000000000000000000523041325016550400163700ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sgerq2.c000077500000000000000000000103071325016550400161070ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgerqf.c000077500000000000000000000134701325016550400161770ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgesc2.c000077500000000000000000000124661325016550400161020ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgesdd.c000077500000000000000000000232311325016550400161550ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgesv.c000077500000000000000000000125621325016550400160400ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgesvd.c000077500000000000000000000231071325016550400162010ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgesvj.c000077500000000000000000000447311325016550400162150ustar00rootroot00000000000000#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@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*); { na_shape_t shape[1]; shape[0] = n; rblapack_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray); } sva = NA_PTR_TYPE(rblapack_sva, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgesvx.c000077500000000000000000000476721325016550400162420ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = 4*n; rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgesvxx.c000077500000000000000000000715331325016550400164230ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sgetc2.c000077500000000000000000000105461325016550400161000ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray); } jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgetf2.c000077500000000000000000000101101325016550400160660ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgetrf.c000077500000000000000000000101161325016550400161740ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgetri.c000077500000000000000000000120411325016550400161760ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sgetrs.c000077500000000000000000000116271325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggbak.c000077500000000000000000000146631325016550400161530ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggbal.c000077500000000000000000000172411325016550400161470ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgges.c000077500000000000000000000330151325016550400160150ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggesx.c000077500000000000000000000425311325016550400162100ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, real*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggev.c000077500000000000000000000251141325016550400160210ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggevx.c000077500000000000000000000445211325016550400162140ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggglm.c000077500000000000000000000210111325016550400161560ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, real*); { na_shape_t shape[1]; shape[0] = p; rblapack_y = na_make_object(NA_SFLOAT, 1, shape, cNArray); } y = NA_PTR_TYPE(rblapack_y, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgghrd.c000077500000000000000000000234471325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgglse.c000077500000000000000000000220441325016550400161710ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggqrf.c000077500000000000000000000227651325016550400162100ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(n,m); rblapack_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, real*); { na_shape_t shape[1]; shape[0] = MIN(n,p); rblapack_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggrqf.c000077500000000000000000000231771325016550400162060ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, real*); { na_shape_t shape[1]; shape[0] = MIN(p,n); rblapack_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggsvd.c000077500000000000000000000321321325016550400162010ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sggsvp.c000077500000000000000000000230571325016550400162230ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgsvj0.c000077500000000000000000000273361325016550400161320ustar00rootroot00000000000000#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@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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgsvj1.c000077500000000000000000000313751325016550400161310ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgtcon.c000077500000000000000000000151641325016550400162070ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sgtrfs.c000077500000000000000000000264161325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgtsv.c000077500000000000000000000151061325016550400160540ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgtsvx.c000077500000000000000000000407531325016550400162520ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgttrf.c000077500000000000000000000145621325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n-2; rblapack_du2 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } du2 = NA_PTR_TYPE(rblapack_du2, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgttrs.c000077500000000000000000000163071325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sgtts2.c000077500000000000000000000152171325016550400161370ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/shgeqz.c000077500000000000000000000364421325016550400162150ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/shsein.c000077500000000000000000000336551325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray); } ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray); } ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/shseqr.c000077500000000000000000000356451325016550400162250ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sisnan.c000077500000000000000000000034011325016550400161740ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sla_gbamv.c000077500000000000000000000201421325016550400166350ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_gbrcond.c000077500000000000000000000211311325016550400171560ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_gbrfsx_extended.c000077500000000000000000000573711325016550400207320ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_gbrpvgrw.c000077500000000000000000000114171325016550400174060ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_geamv.c000077500000000000000000000171111325016550400166420ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_gercond.c000077500000000000000000000173131325016550400171700ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_gerfsx_extended.c000077500000000000000000000566051325016550400207340ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_lin_berr.c000077500000000000000000000107111325016550400173360ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); sla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr); return rblapack_berr; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_porcond.c000077500000000000000000000156031325016550400172130ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_porfsx_extended.c000077500000000000000000000546501325016550400207550ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_porpvgrw.c000077500000000000000000000114711325016550400174340ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_rpvgrw.c000077500000000000000000000075711325016550400171030ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_syamv.c000077500000000000000000000165101325016550400167040ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_syrcond.c000077500000000000000000000172731325016550400172350ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_syrfsx_extended.c000077500000000000000000000562131325016550400207670ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_syrpvgrw.c000077500000000000000000000134571325016550400174570ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sla_wwaddw.c000077500000000000000000000101671325016550400170440ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/slabad.c000077500000000000000000000053321325016550400161340ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slabrd.c000077500000000000000000000210311325016550400161470ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, real*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slacn2.c000077500000000000000000000126371325016550400160760ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slacon.c000077500000000000000000000101441325016550400161620ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slacpy.c000077500000000000000000000070431325016550400162020ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sladiv.c000077500000000000000000000050511325016550400161660ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slae2.c000077500000000000000000000056201325016550400157140ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slaebz.c000077500000000000000000000431711325016550400161710ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed0.c000077500000000000000000000176071325016550400160660ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed1.c000077500000000000000000000201751325016550400160610ustar00rootroot00000000000000#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 occurrence 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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed2.c000077500000000000000000000255001325016550400160570ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dlamda = NA_PTR_TYPE(rblapack_dlamda, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_indxc = na_make_object(NA_LINT, 1, shape, cNArray); } indxc = NA_PTR_TYPE(rblapack_indxc, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray); } coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed3.c000077500000000000000000000226041325016550400160620ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed4.c000077500000000000000000000122501325016550400160570ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed5.c000077500000000000000000000077501325016550400160710ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed6.c000077500000000000000000000121151325016550400160610ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slaed7.c000077500000000000000000000363411325016550400160710ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray); } indxq = NA_PTR_TYPE(rblapack_indxq, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed8.c000077500000000000000000000276731325016550400161020ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dlamda = NA_PTR_TYPE(rblapack_dlamda, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaed9.c000077500000000000000000000143551325016550400160740ustar00rootroot00000000000000#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 ); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaeda.c000077500000000000000000000220331325016550400161340ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaein.c000077500000000000000000000166531325016550400161710ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaev2.c000077500000000000000000000071221325016550400161010ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slaexc.c000077500000000000000000000131031325016550400161600ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slag2.c000077500000000000000000000150061325016550400157150ustar00rootroot00000000000000#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 threshold 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* threshold 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); } ruby-lapack-1.8.1/ext/slag2d.c000077500000000000000000000064411325016550400160640ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slags2.c000077500000000000000000000106261325016550400161030ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slagtf.c000077500000000000000000000172721325016550400161740ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n-2; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray); } in = NA_PTR_TYPE(rblapack_in, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slagtm.c000077500000000000000000000145541325016550400162030ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slagts.c000077500000000000000000000207021325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slagv2.c000077500000000000000000000150771325016550400161130ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = 2; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = 2; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slahqr.c000077500000000000000000000226011325016550400161760ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slahr2.c000077500000000000000000000154411325016550400161030ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slahrd.c000077500000000000000000000146061325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaic1.c000077500000000000000000000110451325016550400160600ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slaln2.c000077500000000000000000000204331325016550400161000ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slals0.c000077500000000000000000000311631325016550400161050ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slalsa.c000077500000000000000000000403171325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slalsd.c000077500000000000000000000204011325016550400161620ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slamrg.c000077500000000000000000000072511325016550400161750ustar00rootroot00000000000000#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 arguments 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaneg.c000077500000000000000000000111531325016550400161550ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slangb.c000077500000000000000000000103761325016550400161600ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slange.c000077500000000000000000000074571325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slangt.c000077500000000000000000000105211325016550400161720ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slanhs.c000077500000000000000000000072161325016550400162010ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slansb.c000077500000000000000000000111311325016550400161620ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slansf.c000077500000000000000000000171461325016550400162020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slansp.c000077500000000000000000000105151325016550400162050ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slanst.c000077500000000000000000000073421325016550400162150ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slansy.c000077500000000000000000000106661325016550400162250ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slantb.c000077500000000000000000000120461325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slantp.c000077500000000000000000000113021325016550400162010ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slantr.c000077500000000000000000000122151325016550400162070ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slanv2.c000077500000000000000000000100011325016550400161000ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slapll.c000077500000000000000000000110231325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slapmr.c000077500000000000000000000103421325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slapmt.c000077500000000000000000000106111325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slapy2.c000077500000000000000000000033751325016550400161250ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slapy3.c000077500000000000000000000036171325016550400161250ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slaqgb.c000077500000000000000000000145701325016550400161630ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqge.c000077500000000000000000000131661325016550400161660ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqp2.c000077500000000000000000000171541325016550400161150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqps.c000077500000000000000000000234651325016550400162200ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = kb; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqr0.c000077500000000000000000000273561325016550400161220ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = ihi; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = ihi; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqr1.c000077500000000000000000000072241325016550400161130ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqr2.c000077500000000000000000000270111325016550400161100ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } sr = NA_PTR_TYPE(rblapack_sr, real*); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray); } si = NA_PTR_TYPE(rblapack_si, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqr3.c000077500000000000000000000264771325016550400161300ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } sr = NA_PTR_TYPE(rblapack_sr, real*); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray); } si = NA_PTR_TYPE(rblapack_si, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqr4.c000077500000000000000000000273561325016550400161260ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = ihi; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = ihi; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqr5.c000077500000000000000000000271451325016550400161230ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqsb.c000077500000000000000000000127701325016550400161770ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqsp.c000077500000000000000000000116221325016550400162100ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; 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); } ruby-lapack-1.8.1/ext/slaqsy.c000077500000000000000000000122301325016550400162150ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaqtr.c000077500000000000000000000152041325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slar1v.c000077500000000000000000000252321325016550400161170ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray); } isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_z_out__ = na_make_object(NA_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); } ruby-lapack-1.8.1/ext/slar2v.c000077500000000000000000000147451325016550400161270ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarf.c000077500000000000000000000111701325016550400160120ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/slarfb.c000077500000000000000000000147241325016550400161640ustar00rootroot00000000000000#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; { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/slarfg.c000077500000000000000000000074021325016550400161640ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarfgp.c000077500000000000000000000074021325016550400163440ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarft.c000077500000000000000000000152711325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarfx.c000077500000000000000000000104051325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/slargv.c000077500000000000000000000113041325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarnv.c000077500000000000000000000072511325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarra.c000077500000000000000000000146271325016550400162010ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray); } isplit = NA_PTR_TYPE(rblapack_isplit, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarrb.c000077500000000000000000000236711325016550400162010ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarrc.c000077500000000000000000000116021325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slarrd.c000077500000000000000000000361721325016550400162030ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } werr = NA_PTR_TYPE(rblapack_werr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray); } iblock = NA_PTR_TYPE(rblapack_iblock, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarre.c000077500000000000000000000340111325016550400161720ustar00rootroot00000000000000#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 occurred 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray); } isplit = NA_PTR_TYPE(rblapack_isplit, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } werr = NA_PTR_TYPE(rblapack_werr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wgap = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wgap = NA_PTR_TYPE(rblapack_wgap, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray); } iblock = NA_PTR_TYPE(rblapack_iblock, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray); } indexw = NA_PTR_TYPE(rblapack_indexw, integer*); { na_shape_t shape[1]; shape[0] = 2*n; rblapack_gers = na_make_object(NA_SFLOAT, 1, shape, cNArray); } gers = NA_PTR_TYPE(rblapack_gers, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarrf.c000077500000000000000000000226041325016550400162000ustar00rootroot00000000000000#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 split).\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*); { na_shape_t shape[1]; shape[0] = n; rblapack_dplus = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dplus = NA_PTR_TYPE(rblapack_dplus, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_lplus = na_make_object(NA_SFLOAT, 1, shape, cNArray); } lplus = NA_PTR_TYPE(rblapack_lplus, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarrj.c000077500000000000000000000173531325016550400162110ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarrk.c000077500000000000000000000123341325016550400162040ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slarrr.c000077500000000000000000000075071325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarrv.c000077500000000000000000000410561325016550400162220ustar00rootroot00000000000000#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 split.) 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 occurred 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarscl2.c000077500000000000000000000065711325016550400164410ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/slartg.c000077500000000000000000000055351325016550400162070ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slartgp.c000077500000000000000000000053561325016550400163700ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slartgs.c000077500000000000000000000051701325016550400163650ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slartv.c000077500000000000000000000131011325016550400162120ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaruv.c000077500000000000000000000072111325016550400162200ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slarz.c000077500000000000000000000121261325016550400160400ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/slarzb.c000077500000000000000000000153371325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/slarzt.c000077500000000000000000000165111325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slas2.c000077500000000000000000000061561325016550400157370ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slascl.c000077500000000000000000000121601325016550400161640ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slascl2.c000077500000000000000000000065361325016550400162600ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/slasd0.c000077500000000000000000000145111325016550400160730ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd1.c000077500000000000000000000231551325016550400161000ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray); } idxq = NA_PTR_TYPE(rblapack_idxq, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd2.c000077500000000000000000000327271325016550400161060ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray); } z = NA_PTR_TYPE(rblapack_z, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dsigma = NA_PTR_TYPE(rblapack_dsigma, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_idxc = na_make_object(NA_LINT, 1, shape, cNArray); } idxc = NA_PTR_TYPE(rblapack_idxc, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray); } coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd3.c000077500000000000000000000266231325016550400161050ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = k; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd4.c000077500000000000000000000127421325016550400161030ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd5.c000077500000000000000000000104631325016550400161020ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd6.c000077500000000000000000000361411325016550400161040ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray); } idxq = NA_PTR_TYPE(rblapack_idxq, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray); } difl = NA_PTR_TYPE(rblapack_difl, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = m; rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray); } z = NA_PTR_TYPE(rblapack_z, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd7.c000077500000000000000000000316741325016550400161130ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = m; rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray); } z = NA_PTR_TYPE(rblapack_z, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dsigma = NA_PTR_TYPE(rblapack_dsigma, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasd8.c000077500000000000000000000220061325016550400161010ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = k; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = k; rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray); } difl = NA_PTR_TYPE(rblapack_difl, real*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasda.c000077500000000000000000000322101325016550400161500ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray); } givptr = NA_PTR_TYPE(rblapack_givptr, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasdq.c000077500000000000000000000254611325016550400162020ustar00rootroot00000000000000#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 whether 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasdt.c000077500000000000000000000067661325016550400162140ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_inode = na_make_object(NA_LINT, 1, shape, cNArray); } inode = NA_PTR_TYPE(rblapack_inode, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_ndiml = na_make_object(NA_LINT, 1, shape, cNArray); } ndiml = NA_PTR_TYPE(rblapack_ndiml, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slaset.c000077500000000000000000000103071325016550400161770ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasq1.c000077500000000000000000000112541325016550400161120ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasq2.c000077500000000000000000000107251325016550400161150ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasq3.c000077500000000000000000000147031325016550400161160ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slasq4.c000077500000000000000000000107401325016550400161140ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slasq5.c000077500000000000000000000105311325016550400161130ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slasq6.c000077500000000000000000000101001325016550400161040ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slasr.c000077500000000000000000000205111325016550400160260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasrt.c000077500000000000000000000060731325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slassq.c000077500000000000000000000070721325016550400162170ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slasv2.c000077500000000000000000000104361325016550400161210ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/slaswp.c000077500000000000000000000106701325016550400162200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasy2.c000077500000000000000000000154041325016550400161240ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slasyf.c000077500000000000000000000141411325016550400162050ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatbs.c000077500000000000000000000246411325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatdf.c000077500000000000000000000177341325016550400161740ustar00rootroot00000000000000#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 chosen 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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatps.c000077500000000000000000000237341325016550400162220ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatrd.c000077500000000000000000000173741325016550400162100ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatrs.c000077500000000000000000000245151325016550400162220ustar00rootroot00000000000000#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]; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatrz.c000077500000000000000000000116551325016550400162320ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slatzm.c000077500000000000000000000157651325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/slauu2.c000077500000000000000000000073041325016550400161220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/slauum.c000077500000000000000000000073021325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sopgtr.c000077500000000000000000000101721325016550400162220ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sopmtr.c000077500000000000000000000143441325016550400162350ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sorbdb.c000077500000000000000000000342631325016550400161660ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } theta = NA_PTR_TYPE(rblapack_theta, real*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } phi = NA_PTR_TYPE(rblapack_phi, real*); { na_shape_t shape[1]; shape[0] = p; rblapack_taup1 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taup1 = NA_PTR_TYPE(rblapack_taup1, real*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_taup2 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } taup2 = NA_PTR_TYPE(rblapack_taup2, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_tauq1 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tauq1 = NA_PTR_TYPE(rblapack_tauq1, real*); { na_shape_t shape[1]; shape[0] = m-q; rblapack_tauq2 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tauq2 = NA_PTR_TYPE(rblapack_tauq2, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sorcsd.c000077500000000000000000000272521325016550400162100ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = p; rblapack_u1 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } u1 = NA_PTR_TYPE(rblapack_u1, real*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_u2 = na_make_object(NA_SFLOAT, 1, shape, cNArray); } u2 = NA_PTR_TYPE(rblapack_u2, real*); { na_shape_t shape[1]; shape[0] = q; rblapack_v1t = na_make_object(NA_SFLOAT, 1, shape, cNArray); } v1t = NA_PTR_TYPE(rblapack_v1t, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sorg2l.c000077500000000000000000000103221325016550400161110ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sorg2r.c000077500000000000000000000103161325016550400161220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sorgbr.c000077500000000000000000000154151325016550400162070ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorghr.c000077500000000000000000000126111325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorgl2.c000077500000000000000000000101561325016550400161160ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sorglq.c000077500000000000000000000123541325016550400162170ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorgql.c000077500000000000000000000124151325016550400162150ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorgqr.c000077500000000000000000000124111325016550400162170ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorgr2.c000077500000000000000000000101761325016550400161260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sorgrq.c000077500000000000000000000123741325016550400162270ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorgtr.c000077500000000000000000000123721325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/sorm2l.c000077500000000000000000000141631325016550400161260ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sorm2r.c000077500000000000000000000141641325016550400161350ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormbr.c000077500000000000000000000220131325016550400162050ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormhr.c000077500000000000000000000200011325016550400162060ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sorml2.c000077500000000000000000000137501325016550400161270ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormlq.c000077500000000000000000000157761325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormql.c000077500000000000000000000162111325016550400162210ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormqr.c000077500000000000000000000162121325016550400162300ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormr2.c000077500000000000000000000137471325016550400161430ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormr3.c000077500000000000000000000155341325016550400161400ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormrq.c000077500000000000000000000157751325016550400162450ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormrz.c000077500000000000000000000167371325016550400162550ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/sormtr.c000077500000000000000000000173471325016550400162450ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/spbcon.c000077500000000000000000000107711325016550400161750ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/spbequ.c000077500000000000000000000113761325016550400162120ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbrfs.c000077500000000000000000000202551325016550400162060ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbstf.c000077500000000000000000000127001325016550400162040ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbsv.c000077500000000000000000000157021325016550400160450ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbsvx.c000077500000000000000000000377501325016550400162440ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbtf2.c000077500000000000000000000122241325016550400161040ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbtrf.c000077500000000000000000000120711325016550400162040ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spbtrs.c000077500000000000000000000120671325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spftrf.c000077500000000000000000000170721325016550400162160ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spftri.c000077500000000000000000000164741325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spftrs.c000077500000000000000000000167651325016550400162430ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spocon.c000077500000000000000000000076011325016550400162100ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/spoequ.c000077500000000000000000000077371325016550400162350ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spoequb.c000077500000000000000000000077501325016550400163720ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sporfs.c000077500000000000000000000175451325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sporfsx.c000077500000000000000000000477421325016550400164250ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/sposv.c000077500000000000000000000133521325016550400160610ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sposvx.c000077500000000000000000000357541325016550400162630ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sposvxx.c000077500000000000000000000623031325016550400164410ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/spotf2.c000077500000000000000000000100241325016550400161150ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spotrf.c000077500000000000000000000077051325016550400162310ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spotri.c000077500000000000000000000072771325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spotrs.c000077500000000000000000000101331325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sppcon.c000077500000000000000000000100411325016550400162010ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sppequ.c000077500000000000000000000105041325016550400162200ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/spprfs.c000077500000000000000000000171761325016550400162340ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sppsv.c000077500000000000000000000142331325016550400160610ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sppsvx.c000077500000000000000000000360621325016550400162550ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/spptrf.c000077500000000000000000000104571325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; 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); } ruby-lapack-1.8.1/ext/spptri.c000077500000000000000000000072771325016550400162410ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; 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); } ruby-lapack-1.8.1/ext/spptrs.c000077500000000000000000000113271325016550400162420ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spstf2.c000077500000000000000000000124701325016550400161300ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/spstrf.c000077500000000000000000000124661325016550400162350ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sptcon.c000077500000000000000000000103151325016550400162110ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/spteqr.c000077500000000000000000000164111325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sptrfs.c000077500000000000000000000175361325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sptsv.c000077500000000000000000000134551325016550400160720ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sptsvx.c000077500000000000000000000260341325016550400162570ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/spttrf.c000077500000000000000000000103351325016550400162270ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/spttrs.c000077500000000000000000000116721325016550400162510ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sptts2.c000077500000000000000000000107331325016550400161460ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/srscl.c000077500000000000000000000062611325016550400160360ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbev.c000077500000000000000000000133251325016550400160310ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbevd.c000077500000000000000000000215411325016550400161740ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbevx.c000077500000000000000000000252151325016550400162220ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbgst.c000077500000000000000000000144321325016550400162140ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbgv.c000077500000000000000000000202301325016550400160240ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbgvd.c000077500000000000000000000257221325016550400162030ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbgvx.c000077500000000000000000000311711325016550400162220ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 7*n; rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = 5*n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[1]; shape[0] = m; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssbtrd.c000077500000000000000000000154351325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssfrk.c000077500000000000000000000146221325016550400160400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspcon.c000077500000000000000000000111531325016550400162110ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/sspev.c000077500000000000000000000123651325016550400160520ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspevd.c000077500000000000000000000205761325016550400162210ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspevx.c000077500000000000000000000227411325016550400162410ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspgst.c000077500000000000000000000115401325016550400162270ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; 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); } ruby-lapack-1.8.1/ext/sspgv.c000077500000000000000000000172241325016550400160530ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspgvd.c000077500000000000000000000246651325016550400162260ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspgvx.c000077500000000000000000000302411325016550400162350ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssprfs.c000077500000000000000000000204771325016550400162350ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspsv.c000077500000000000000000000162771325016550400160760ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sspsvx.c000077500000000000000000000315601325016550400162560ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssptrd.c000077500000000000000000000135361325016550400162320ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssptrf.c000077500000000000000000000147201325016550400162300ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssptri.c000077500000000000000000000110411325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; 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); } ruby-lapack-1.8.1/ext/ssptrs.c000077500000000000000000000115541325016550400162470ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstebz.c000077500000000000000000000264061325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray); } iblock = NA_PTR_TYPE(rblapack_iblock, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstedc.c000077500000000000000000000243021325016550400161710ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstegr.c000077500000000000000000000302601325016550400162130ustar00rootroot00000000000000#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 compatibility 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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstein.c000077500000000000000000000177121325016550400162200ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstemr.c000077500000000000000000000370051325016550400162250ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssteqr.c000077500000000000000000000152311325016550400162260ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssterf.c000077500000000000000000000075551325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstev.c000077500000000000000000000121131325016550400160450ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstevd.c000077500000000000000000000201141325016550400162110ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstevr.c000077500000000000000000000342331325016550400162360ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/sstevx.c000077500000000000000000000233151325016550400162430ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssycon.c000077500000000000000000000113111325016550400162160ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ssyconv.c000077500000000000000000000106021325016550400164060ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ssyequb.c000077500000000000000000000114521325016550400164010ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssyev.c000077500000000000000000000130521325016550400160550ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/ssyevd.c000077500000000000000000000205161325016550400162240ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssyevr.c000077500000000000000000000360311325016550400162410ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssyevx.c000077500000000000000000000247571325016550400162630ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssygs2.c000077500000000000000000000120651325016550400161410ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssygst.c000077500000000000000000000120621325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssygv.c000077500000000000000000000202431325016550400160570ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssygvd.c000077500000000000000000000255441325016550400162340ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssygvx.c000077500000000000000000000324311325016550400162510ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, real*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssyrfs.c000077500000000000000000000212701325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssyrfsx.c000077500000000000000000000514341325016550400164330ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/ssysv.c000077500000000000000000000202201325016550400160660ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssysvx.c000077500000000000000000000332661325016550400162740ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssysvxx.c000077500000000000000000000650111325016550400164550ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/ssyswapr.c000077500000000000000000000076361325016550400166120ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytd2.c000077500000000000000000000152611325016550400161400ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytf2.c000077500000000000000000000162331325016550400161420ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytrd.c000077500000000000000000000171401325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, real*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/ssytrf.c000077500000000000000000000200621325016550400162350ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/ssytri.c000077500000000000000000000111771325016550400162470ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytri2.c000077500000000000000000000154071325016550400163310ustar00rootroot00000000000000#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); } { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytri2x.c000077500000000000000000000115251325016550400165160ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytrs.c000077500000000000000000000116721325016550400162610ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ssytrs2.c000077500000000000000000000121441325016550400163360ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stbcon.c000077500000000000000000000113731325016550400162000ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/stbrfs.c000077500000000000000000000167541325016550400162230ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); work = ALLOC_N(real, (3*n)); iwork = ALLOC_N(integer, (n)); 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); } ruby-lapack-1.8.1/ext/stbtrs.c000077500000000000000000000131021325016550400162210ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stfsm.c000077500000000000000000000247341325016550400160510ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stftri.c000077500000000000000000000171421325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stfttp.c000077500000000000000000000152731325016550400162370ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stfttr.c000077500000000000000000000165571325016550400162470ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stgevc.c000077500000000000000000000324121325016550400162000ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/stgex2.c000077500000000000000000000246221325016550400161250ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/stgexc.c000077500000000000000000000256031325016550400162060ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/stgsen.c000077500000000000000000000543511325016550400162160ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphar = NA_PTR_TYPE(rblapack_alphar, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alphai = NA_PTR_TYPE(rblapack_alphai, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t shape[1]; shape[0] = 2; rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/stgsja.c000077500000000000000000000372421325016550400162060ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, real*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/stgsna.c000077500000000000000000000410711325016550400162050ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t shape[1]; shape[0] = mm; rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); 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); } ruby-lapack-1.8.1/ext/stgsy2.c000077500000000000000000000312571325016550400161460ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; { na_shape_t shape[2]; shape[0] = ldf; shape[1] = n; rblapack_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } f_out__ = NA_PTR_TYPE(rblapack_f_out__, real*); MEMCPY(f_out__, f, real, NA_TOTAL(rblapack_f)); rblapack_f = rblapack_f_out__; f = f_out__; iwork = ALLOC_N(integer, (m+n+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); } ruby-lapack-1.8.1/ext/stgsyl.c000077500000000000000000000332331325016550400162340ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID stgsyl_(char* trans, integer* ijob, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb, real* c, integer* ldc, real* d, integer* ldd, real* e, integer* lde, real* f, integer* ldf, real* scale, real* dif, real* work, integer* lwork, integer* iwork, integer* info); static VALUE rblapack_stgsyl(int argc, VALUE *argv, VALUE self){ VALUE rblapack_trans; char trans; VALUE rblapack_ijob; integer ijob; VALUE rblapack_a; real *a; VALUE rblapack_b; real *b; VALUE rblapack_c; real *c; VALUE rblapack_d; real *d; VALUE rblapack_e; real *e; VALUE rblapack_f; real *f; VALUE rblapack_lwork; integer lwork; VALUE rblapack_scale; real scale; VALUE rblapack_dif; real dif; VALUE rblapack_work; real *work; VALUE rblapack_info; integer info; VALUE rblapack_c_out__; real *c_out__; VALUE rblapack_f_out__; real *f_out__; integer *iwork; integer lda; integer m; integer ldb; integer n; integer ldc; integer ldd; integer lde; integer ldf; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGSYL solves the generalized Sylvester equation:\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F\n*\n* where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n* respectively, with real entries. (A, D) and (B, E) must be in\n* generalized (real) Schur canonical form, i.e. A, B are upper quasi\n* triangular and D, E are upper triangular.\n*\n* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n* scaling factor chosen to avoid overflow.\n*\n* In matrix notation (1) is equivalent to solve Zx = scale b, where\n* Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ].\n*\n* Here Ik is the identity matrix of size k and X' is the transpose of\n* X. kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n* If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,\n* which is equivalent to solve for R and L in\n*\n* A' * R + D' * L = scale * C (3)\n* R * B' + L * E' = scale * (-F)\n*\n* This case (TRANS = 'T') is used to compute an one-norm-based estimate\n* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n* and (B,E), using SLACON.\n*\n* If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate\n* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n* reciprocal of the smallest singular value of Z. See [1-2] for more\n* information.\n*\n* This is a level 3 BLAS algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N', solve the generalized Sylvester equation (1).\n* = 'T', solve the 'transposed' system (3).\n*\n* IJOB (input) INTEGER\n* Specifies what kind of functionality to be performed.\n* =0: solve (1) only.\n* =1: The functionality of 0 and 3.\n* =2: The functionality of 0 and 4.\n* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n* (look ahead strategy IJOB = 1 is used).\n* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n* ( SGECON on sub-systems is used ).\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* The order of the matrices A and D, and the row dimension of\n* the matrices C, F, R and L.\n*\n* N (input) INTEGER\n* The order of the matrices B and E, and the column dimension\n* of the matrices C, F, R and L.\n*\n* A (input) REAL array, dimension (LDA, M)\n* The upper quasi triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, M).\n*\n* B (input) REAL array, dimension (LDB, N)\n* The upper quasi triangular matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1, N).\n*\n* C (input/output) REAL array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1) or (3).\n* On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n* the solution achieved during the computation of the\n* Dif-estimate.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1, M).\n*\n* D (input) REAL array, dimension (LDD, M)\n* The upper triangular matrix D.\n*\n* LDD (input) INTEGER\n* The leading dimension of the array D. LDD >= max(1, M).\n*\n* E (input) REAL array, dimension (LDE, N)\n* The upper triangular matrix E.\n*\n* LDE (input) INTEGER\n* The leading dimension of the array E. LDE >= max(1, N).\n*\n* F (input/output) REAL array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1) or (3).\n* On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n* the solution achieved during the computation of the\n* Dif-estimate.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1, M).\n*\n* DIF (output) REAL\n* On exit DIF is the reciprocal of a lower bound of the\n* reciprocal of the Dif-function, i.e. DIF is an upper bound of\n* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).\n* IF IJOB = 0 or TRANS = 'T', DIF is not touched.\n*\n* SCALE (output) REAL\n* On exit SCALE is the scaling factor in (1) or (3).\n* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n* to a slightly perturbed system but the input matrices A, B, D\n* and E have not been changed. If SCALE = 0, C and F hold the\n* solutions R and L, respectively, to the homogeneous system\n* with C = F = 0. Normally, SCALE = 1.\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK > = 1.\n* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array, and no error\n* message related to LWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (M+N+6)\n*\n* INFO (output) INTEGER\n* =0: successful exit\n* <0: If INFO = -i, the i-th argument had an illegal value.\n* >0: (A, D) and (B, E) have common or close eigenvalues.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n* Umea University, S-901 87 Umea, Sweden.\n*\n* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n* for Solving the Generalized Sylvester Equation and Estimating the\n* Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n* Department of Computing Science, Umea University, S-901 87 Umea,\n* Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n* No 1, 1996.\n*\n* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n* Appl., 15(4):1045-1060, 1994\n*\n* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n* Condition Estimators for Solving the Generalized Sylvester\n* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n* July 1989, pp 745-751.\n*\n* =====================================================================\n* Replaced various illegal calls to SCOPY by calls to SLASET.\n* Sven Hammarling, 1/5/02.\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 8 && argc != 9) rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc); rblapack_trans = argv[0]; rblapack_ijob = argv[1]; rblapack_a = argv[2]; rblapack_b = argv[3]; rblapack_c = argv[4]; rblapack_d = argv[5]; rblapack_e = argv[6]; rblapack_f = argv[7]; if (argc == 9) { rblapack_lwork = argv[8]; } else if (rblapack_options != Qnil) { rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork"))); } else { rblapack_lwork = Qnil; } trans = StringValueCStr(rblapack_trans)[0]; if (!NA_IsNArray(rblapack_a)) rb_raise(rb_eArgError, "a (3th argument) must be NArray"); if (NA_RANK(rblapack_a) != 2) rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2); lda = NA_SHAPE0(rblapack_a); m = NA_SHAPE1(rblapack_a); if (NA_TYPE(rblapack_a) != NA_SFLOAT) rblapack_a = na_change_type(rblapack_a, NA_SFLOAT); a = NA_PTR_TYPE(rblapack_a, real*); if (!NA_IsNArray(rblapack_c)) rb_raise(rb_eArgError, "c (5th argument) must be NArray"); if (NA_RANK(rblapack_c) != 2) rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2); ldc = NA_SHAPE0(rblapack_c); n = NA_SHAPE1(rblapack_c); if (NA_TYPE(rblapack_c) != NA_SFLOAT) rblapack_c = na_change_type(rblapack_c, NA_SFLOAT); c = NA_PTR_TYPE(rblapack_c, real*); if (!NA_IsNArray(rblapack_e)) rb_raise(rb_eArgError, "e (7th argument) must be NArray"); if (NA_RANK(rblapack_e) != 2) rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2); lde = NA_SHAPE0(rblapack_e); if (NA_SHAPE1(rblapack_e) != n) rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c"); if (NA_TYPE(rblapack_e) != NA_SFLOAT) rblapack_e = na_change_type(rblapack_e, NA_SFLOAT); e = NA_PTR_TYPE(rblapack_e, real*); ijob = NUM2INT(rblapack_ijob); if (!NA_IsNArray(rblapack_d)) rb_raise(rb_eArgError, "d (6th argument) must be NArray"); if (NA_RANK(rblapack_d) != 2) rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2); ldd = NA_SHAPE0(rblapack_d); if (NA_SHAPE1(rblapack_d) != m) rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a"); if (NA_TYPE(rblapack_d) != NA_SFLOAT) rblapack_d = na_change_type(rblapack_d, NA_SFLOAT); d = NA_PTR_TYPE(rblapack_d, real*); if (!NA_IsNArray(rblapack_b)) rb_raise(rb_eArgError, "b (4th argument) must be NArray"); if (NA_RANK(rblapack_b) != 2) rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2); ldb = NA_SHAPE0(rblapack_b); if (NA_SHAPE1(rblapack_b) != n) rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c"); if (NA_TYPE(rblapack_b) != NA_SFLOAT) rblapack_b = na_change_type(rblapack_b, NA_SFLOAT); b = NA_PTR_TYPE(rblapack_b, real*); if (!NA_IsNArray(rblapack_f)) rb_raise(rb_eArgError, "f (8th argument) must be NArray"); if (NA_RANK(rblapack_f) != 2) rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2); ldf = NA_SHAPE0(rblapack_f); if (NA_SHAPE1(rblapack_f) != n) rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c"); if (NA_TYPE(rblapack_f) != NA_SFLOAT) rblapack_f = na_change_type(rblapack_f, NA_SFLOAT); f = NA_PTR_TYPE(rblapack_f, real*); if (rblapack_lwork == Qnil) lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1; else { lwork = NUM2INT(rblapack_lwork); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; { na_shape_t shape[2]; shape[0] = ldf; shape[1] = n; rblapack_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } f_out__ = NA_PTR_TYPE(rblapack_f_out__, real*); MEMCPY(f_out__, f, real, NA_TOTAL(rblapack_f)); rblapack_f = rblapack_f_out__; f = f_out__; iwork = ALLOC_N(integer, (m+n+6)); stgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info); free(iwork); rblapack_scale = rb_float_new((double)scale); rblapack_dif = rb_float_new((double)dif); rblapack_info = INT2NUM(info); return rb_ary_new3(6, rblapack_scale, rblapack_dif, rblapack_work, rblapack_info, rblapack_c, rblapack_f); } void init_lapack_stgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "stgsyl", rblapack_stgsyl, -1); } ruby-lapack-1.8.1/ext/stpcon.c000077500000000000000000000105341325016550400162140ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/stprfs.c000077500000000000000000000161671325016550400162370ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID stprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info); static VALUE rblapack_stprfs(int argc, VALUE *argv, VALUE self){ VALUE rblapack_uplo; char uplo; VALUE rblapack_trans; char trans; VALUE rblapack_diag; char diag; VALUE rblapack_ap; real *ap; VALUE rblapack_b; real *b; VALUE rblapack_x; real *x; VALUE rblapack_ferr; real *ferr; VALUE rblapack_berr; real *berr; VALUE rblapack_info; integer info; real *work; integer *iwork; integer ldb; integer nrhs; integer ldx; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STPRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular packed\n* coefficient matrix.\n*\n* The solution matrix X must be computed by STPTRS or some other\n* means before entering this routine. STPRFS does not do iterative\n* refinement because doing so cannot improve the backward error.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* TRANS (input) CHARACTER*1\n* Specifies the form of the system of equations:\n* = 'N': A * X = B (No transpose)\n* = 'T': A**T * X = B (Transpose)\n* = 'C': A**H * X = B (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* = 'N': A is non-unit triangular;\n* = 'U': A is unit triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices B and X. NRHS >= 0.\n*\n* AP (input) REAL array, dimension (N*(N+1)/2)\n* The upper or lower triangular matrix A, packed columnwise in\n* a linear array. The j-th column of A is stored in the array\n* AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The right hand side matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (input) REAL array, dimension (LDX,NRHS)\n* The solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* FERR (output) REAL array, dimension (NRHS)\n* The estimated forward error bound for each solution vector\n* X(j) (the j-th column of the solution matrix X).\n* If XTRUE is the true solution corresponding to X(j), FERR(j)\n* is an estimated upper bound for the magnitude of the largest\n* element in (X(j) - XTRUE) divided by the magnitude of the\n* largest element in X(j). The estimate is as reliable as\n* the estimate for RCOND, and is almost always a slight\n* overestimate of the true error.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* The componentwise relative backward error of each solution\n* vector X(j) (i.e., the smallest relative change in\n* any element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 6 && argc != 6) rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc); rblapack_uplo = argv[0]; rblapack_trans = argv[1]; rblapack_diag = argv[2]; rblapack_ap = argv[3]; rblapack_b = argv[4]; rblapack_x = argv[5]; if (argc == 6) { } else if (rblapack_options != Qnil) { } else { } uplo = StringValueCStr(rblapack_uplo)[0]; diag = StringValueCStr(rblapack_diag)[0]; if (!NA_IsNArray(rblapack_b)) rb_raise(rb_eArgError, "b (5th argument) must be NArray"); if (NA_RANK(rblapack_b) != 2) rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2); ldb = NA_SHAPE0(rblapack_b); nrhs = NA_SHAPE1(rblapack_b); if (NA_TYPE(rblapack_b) != NA_SFLOAT) rblapack_b = na_change_type(rblapack_b, NA_SFLOAT); b = NA_PTR_TYPE(rblapack_b, real*); n = ldb; trans = StringValueCStr(rblapack_trans)[0]; if (!NA_IsNArray(rblapack_x)) rb_raise(rb_eArgError, "x (6th argument) must be NArray"); if (NA_RANK(rblapack_x) != 2) rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2); ldx = NA_SHAPE0(rblapack_x); if (NA_SHAPE1(rblapack_x) != nrhs) rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b"); if (NA_TYPE(rblapack_x) != NA_SFLOAT) rblapack_x = na_change_type(rblapack_x, NA_SFLOAT); x = NA_PTR_TYPE(rblapack_x, real*); if (!NA_IsNArray(rblapack_ap)) rb_raise(rb_eArgError, "ap (4th argument) must be NArray"); if (NA_RANK(rblapack_ap) != 1) rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1); if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2)) rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2); if (NA_TYPE(rblapack_ap) != NA_SFLOAT) rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT); ap = NA_PTR_TYPE(rblapack_ap, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); work = ALLOC_N(real, (3*n)); iwork = ALLOC_N(integer, (n)); stprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info); free(work); free(iwork); rblapack_info = INT2NUM(info); return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info); } void init_lapack_stprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "stprfs", rblapack_stprfs, -1); } ruby-lapack-1.8.1/ext/stptri.c000077500000000000000000000106771325016550400162430ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID stptri_(char* uplo, char* diag, integer* n, real* ap, integer* info); static VALUE rblapack_stptri(int argc, VALUE *argv, VALUE self){ VALUE rblapack_uplo; char uplo; VALUE rblapack_diag; char diag; VALUE rblapack_n; integer n; VALUE rblapack_ap; real *ap; VALUE rblapack_info; integer info; VALUE rblapack_ap_out__; real *ap_out__; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* STPTRI computes the inverse of a real upper or lower triangular\n* matrix A stored in packed format.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* DIAG (input) CHARACTER*1\n* = 'N': A is non-unit triangular;\n* = 'U': A is unit triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangular matrix A, stored\n* columnwise in a linear array. The j-th column of A is stored\n* in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same packed storage format.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, A(i,i) is exactly zero. The triangular\n* matrix is singular and its inverse can not be computed.\n*\n\n* Further Details\n* ===============\n*\n* A triangular matrix A can be transferred to packed storage using one\n* of the following program segments:\n*\n* UPLO = 'U': UPLO = 'L':\n*\n* JC = 1 JC = 1\n* DO 2 J = 1, N DO 2 J = 1, N\n* DO 1 I = 1, J DO 1 I = J, N\n* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)\n* 1 CONTINUE 1 CONTINUE\n* JC = JC + J JC = JC + N - J + 1\n* 2 CONTINUE 2 CONTINUE\n*\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 4 && argc != 4) rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc); rblapack_uplo = argv[0]; rblapack_diag = argv[1]; rblapack_n = argv[2]; rblapack_ap = argv[3]; if (argc == 4) { } else if (rblapack_options != Qnil) { } else { } uplo = StringValueCStr(rblapack_uplo)[0]; n = NUM2INT(rblapack_n); diag = StringValueCStr(rblapack_diag)[0]; if (!NA_IsNArray(rblapack_ap)) rb_raise(rb_eArgError, "ap (4th argument) must be NArray"); if (NA_RANK(rblapack_ap) != 1) rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1); if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2)) rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2); if (NA_TYPE(rblapack_ap) != NA_SFLOAT) rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT); ap = NA_PTR_TYPE(rblapack_ap, real*); { na_shape_t shape[1]; shape[0] = n*(n+1)/2; rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*); MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap)); rblapack_ap = rblapack_ap_out__; ap = ap_out__; stptri_(&uplo, &diag, &n, ap, &info); rblapack_info = INT2NUM(info); return rb_ary_new3(2, rblapack_info, rblapack_ap); } void init_lapack_stptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "stptri", rblapack_stptri, -1); } ruby-lapack-1.8.1/ext/stptrs.c000077500000000000000000000123001325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stpttf.c000077500000000000000000000153141325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stpttr.c000077500000000000000000000073341325016550400162520ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/strcon.c000077500000000000000000000110721325016550400162140ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/strevc.c000077500000000000000000000251671325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/strexc.c000077500000000000000000000145401325016550400162170ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/strrfs.c000077500000000000000000000164531325016550400162370ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, real*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, real*); work = ALLOC_N(real, (3*n)); iwork = ALLOC_N(integer, (n)); 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); } ruby-lapack-1.8.1/ext/strsen.c000077500000000000000000000343611325016550400162300ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wr = NA_PTR_TYPE(rblapack_wr, real*); { na_shape_t shape[1]; shape[0] = n; rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray); } wi = NA_PTR_TYPE(rblapack_wi, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/strsna.c000077500000000000000000000261301325016550400162170ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/strsyl.c000077500000000000000000000150571325016550400162530ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray); } c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*); MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c)); rblapack_c = rblapack_c_out__; c = c_out__; 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); } ruby-lapack-1.8.1/ext/strti2.c000077500000000000000000000100241325016550400161270ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/strtri.c000077500000000000000000000100531325016550400162310ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/strtrs.c000077500000000000000000000126061325016550400162510ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/strttf.c000077500000000000000000000163011325016550400162320ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/strttp.c000077500000000000000000000072271325016550400162530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stzrqf.c000077500000000000000000000114611325016550400162370ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/stzrzf.c000077500000000000000000000140201325016550400162420ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, real*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, real*); { na_shape_t shape[2]; shape[0] = 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); } ruby-lapack-1.8.1/ext/xerbla.c000077500000000000000000000041611325016550400161620ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/xerbla_array.c000077500000000000000000000062461325016550400173660ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zbbcsd.c000077500000000000000000000413101325016550400161510ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b11d = NA_PTR_TYPE(rblapack_b11d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b11e = NA_PTR_TYPE(rblapack_b11e, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b12d = NA_PTR_TYPE(rblapack_b12d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b12e = NA_PTR_TYPE(rblapack_b12e, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b21d = NA_PTR_TYPE(rblapack_b21d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b21e = NA_PTR_TYPE(rblapack_b21e, doublereal*); { na_shape_t shape[1]; shape[0] = q; rblapack_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b22d = NA_PTR_TYPE(rblapack_b22d, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } b22e = NA_PTR_TYPE(rblapack_b22e, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zbdsqr.c000077500000000000000000000271231325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zcgesv.c000077500000000000000000000204401325016550400162040ustar00rootroot00000000000000#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 successfully 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zcposv.c000077500000000000000000000207411325016550400162330ustar00rootroot00000000000000#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 successfully 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); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zdrscl.c000077500000000000000000000064231325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbbrd.c000077500000000000000000000201241325016550400161540ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbcon.c000077500000000000000000000127371325016550400161770ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zgbequ.c000077500000000000000000000134301325016550400162010ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,m); rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbequb.c000077500000000000000000000141231325016550400163430ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbrfs.c000077500000000000000000000226621325016550400162100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbrfsx.c000077500000000000000000000571661325016550400164070ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zgbsv.c000077500000000000000000000164601325016550400160450ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbsvx.c000077500000000000000000000532041325016550400162320ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbsvxx.c000077500000000000000000000742541325016550400164320ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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]; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zgbtf2.c000077500000000000000000000132141325016550400161020ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbtrf.c000077500000000000000000000132051325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgbtrs.c000077500000000000000000000132761325016550400162270ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgebak.c000077500000000000000000000121371325016550400161520ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgebal.c000077500000000000000000000141071325016550400161520ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgebd2.c000077500000000000000000000174271325016550400160730ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgebrd.c000077500000000000000000000215231325016550400161630ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgecon.c000077500000000000000000000100641325016550400161710ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zgeequ.c000077500000000000000000000121441325016550400162050ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgeequb.c000077500000000000000000000127471325016550400163600ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray); } r = NA_PTR_TYPE(rblapack_r, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgees.c000077500000000000000000000211461325016550400160240ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeesx.c000077500000000000000000000252751325016550400162230ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeev.c000077500000000000000000000166321325016550400160330ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeevx.c000077500000000000000000000316331325016550400162210ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } scale = NA_PTR_TYPE(rblapack_scale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgegs.c000077500000000000000000000250041325016550400160230ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgegv.c000077500000000000000000000324461325016550400160360ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = 8*n; rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgehd2.c000077500000000000000000000130731325016550400160720ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgehrd.c000077500000000000000000000155731325016550400162010ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgelq2.c000077500000000000000000000103551325016550400161130ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgelqf.c000077500000000000000000000134731325016550400162030ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgels.c000077500000000000000000000212711325016550400160320ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgelsd.c000077500000000000000000000252211325016550400161750ustar00rootroot00000000000000#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 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 transformations 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); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgelss.c000077500000000000000000000205061325016550400162150ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgelsx.c000077500000000000000000000206771325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgelsy.c000077500000000000000000000245421325016550400162270ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgeql2.c000077500000000000000000000106271325016550400161150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeqlf.c000077500000000000000000000136761325016550400162100ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeqp3.c000077500000000000000000000156461325016550400161300ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgeqpf.c000077500000000000000000000140631325016550400162030ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgeqr2.c000077500000000000000000000104451325016550400161210ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeqr2p.c000077500000000000000000000104571325016550400163040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeqrf.c000077500000000000000000000135051325016550400162050ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgeqrfp.c000077500000000000000000000135201325016550400163620ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgerfs.c000077500000000000000000000207561325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgerfsx.c000077500000000000000000000532141325016550400164000ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zgerq2.c000077500000000000000000000105351325016550400161210ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgerqf.c000077500000000000000000000137201325016550400162040ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgesc2.c000077500000000000000000000127031325016550400161030ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgesdd.c000077500000000000000000000242421325016550400161670ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgesv.c000077500000000000000000000127711325016550400160510ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgesvd.c000077500000000000000000000236661325016550400162220ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgesvx.c000077500000000000000000000506431325016550400162410ustar00rootroot00000000000000#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 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*); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = 2*n; rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgesvxx.c000077500000000000000000000723551325016550400164350ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zgetc2.c000077500000000000000000000106661325016550400161120ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray); } jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgetf2.c000077500000000000000000000102121325016550400161000ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgetrf.c000077500000000000000000000102201325016550400161770ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgetri.c000077500000000000000000000122061325016550400162100ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zgetrs.c000077500000000000000000000120151325016550400162200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggbak.c000077500000000000000000000150651325016550400161570ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggbal.c000077500000000000000000000175621325016550400161640ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgges.c000077500000000000000000000315601325016550400160270ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggesx.c000077500000000000000000000404511325016550400162160ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*); { na_shape_t shape[1]; shape[0] = 2; rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggev.c000077500000000000000000000243471325016550400160370ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = 8*n; rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggevx.c000077500000000000000000000430621325016550400162220ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggglm.c000077500000000000000000000214701325016550400161760ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublecomplex*); { na_shape_t shape[1]; shape[0] = p; rblapack_y = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } y = NA_PTR_TYPE(rblapack_y, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgghrd.c000077500000000000000000000240031325016550400161670ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgglse.c000077500000000000000000000225661325016550400162110ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggqrf.c000077500000000000000000000233431325016550400162100ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(n,m); rblapack_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, doublecomplex*); { na_shape_t shape[1]; shape[0] = MIN(n,p); rblapack_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggrqf.c000077500000000000000000000235551325016550400162150ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taua = NA_PTR_TYPE(rblapack_taua, doublecomplex*); { na_shape_t shape[1]; shape[0] = MIN(p,n); rblapack_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taub = NA_PTR_TYPE(rblapack_taub, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggsvd.c000077500000000000000000000331301325016550400162070ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zggsvp.c000077500000000000000000000240471325016550400162320ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgtcon.c000077500000000000000000000152761325016550400162220ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zgtrfs.c000077500000000000000000000273331325016550400162320ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgtsv.c000077500000000000000000000154741325016550400160730ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgtsvx.c000077500000000000000000000420671325016550400162610ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgttrf.c000077500000000000000000000151361325016550400162310ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n-2; rblapack_du2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgttrs.c000077500000000000000000000166601325016550400162510ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zgtts2.c000077500000000000000000000157001325016550400161430ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbev.c000077500000000000000000000140501325016550400160210ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbevd.c000077500000000000000000000250011325016550400161630ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbevx.c000077500000000000000000000254411325016550400162170ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbgst.c000077500000000000000000000151521325016550400162100ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbgv.c000077500000000000000000000210531325016550400160240ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbgvd.c000077500000000000000000000311721325016550400161730ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbgvx.c000077500000000000000000000312661325016550400162230ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhbtrd.c000077500000000000000000000157771325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhecon.c000077500000000000000000000112231325016550400161700ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zheequb.c000077500000000000000000000104641325016550400163530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zheev.c000077500000000000000000000135621325016550400160330ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zheevd.c000077500000000000000000000234571325016550400162030ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zheevr.c000077500000000000000000000410611325016550400162100ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zheevx.c000077500000000000000000000256351325016550400162270ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhegs2.c000077500000000000000000000122371325016550400161120ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhegst.c000077500000000000000000000122341325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhegv.c000077500000000000000000000210551325016550400160310ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhegvd.c000077500000000000000000000310201325016550400161660ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhegvx.c000077500000000000000000000330511325016550400162200ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zherfs.c000077500000000000000000000217301325016550400162070ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zherfsx.c000077500000000000000000000523311325016550400164000ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zhesv.c000077500000000000000000000201731325016550400160450ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhesvx.c000077500000000000000000000337641325016550400162470ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhesvxx.c000077500000000000000000000653701325016550400164350ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zhetd2.c000077500000000000000000000155401325016550400161100ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhetf2.c000077500000000000000000000162171325016550400161140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhetrd.c000077500000000000000000000174511325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhetrf.c000077500000000000000000000176001325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhetri.c000077500000000000000000000113451325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zhetrs.c000077500000000000000000000120441325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhetrs2.c000077500000000000000000000123231325016550400163050ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhfrk.c000077500000000000000000000155031325016550400160330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhgeqz.c000077500000000000000000000343131325016550400162170ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpcon.c000077500000000000000000000110651325016550400162070ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zhpev.c000077500000000000000000000131601325016550400160400ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpevd.c000077500000000000000000000240471325016550400162120ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpevx.c000077500000000000000000000235531325016550400162370ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpgst.c000077500000000000000000000117121325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpgv.c000077500000000000000000000200641325016550400160430ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpgvd.c000077500000000000000000000303331325016550400162070ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpgvx.c000077500000000000000000000310371325016550400162350ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray); } ifail = NA_PTR_TYPE(rblapack_ifail, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhprfs.c000077500000000000000000000211371325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpsv.c000077500000000000000000000165151325016550400160650ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhpsvx.c000077500000000000000000000322161325016550400162510ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhptrd.c000077500000000000000000000140111325016550400162130ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhptrf.c000077500000000000000000000150041325016550400162200ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhptri.c000077500000000000000000000112071325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhptrs.c000077500000000000000000000117261325016550400162440ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhsein.c000077500000000000000000000301631325016550400162060ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray); } ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*); { na_shape_t shape[1]; shape[0] = mm; rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray); } ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zhseqr.c000077500000000000000000000342561325016550400162310ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zla_gbamv.c000077500000000000000000000203461325016550400166520ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gbrcond_c.c000077500000000000000000000211461325016550400174750ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gbrcond_x.c000077500000000000000000000205221325016550400175170ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gbrfsx_extended.c000077500000000000000000000606271325016550400207370ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gbrpvgrw.c000077500000000000000000000121401325016550400174070ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_geamv.c000077500000000000000000000173541325016550400166620ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gercond_c.c000077500000000000000000000173541325016550400175060ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gercond_x.c000077500000000000000000000167701325016550400175340ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_gerfsx_extended.c000077500000000000000000000565311325016550400207410ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_heamv.c000077500000000000000000000166661325016550400166700ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_hercond_c.c000077500000000000000000000171061325016550400175020ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_hercond_x.c000077500000000000000000000164671325016550400175400ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_herfsx_extended.c000077500000000000000000000573611325016550400207440ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_herpvgrw.c000077500000000000000000000142161325016550400174210ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_lin_berr.c000077500000000000000000000113671325016550400173550ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_porcond_c.c000077500000000000000000000156161325016550400175300ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_porcond_x.c000077500000000000000000000151511325016550400175470ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_porfsx_extended.c000077500000000000000000000560311325016550400207570ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_porpvgrw.c000077500000000000000000000122601325016550400174400ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_rpvgrw.c000077500000000000000000000102751325016550400171050ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_syamv.c000077500000000000000000000166621325016550400167230ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_syrcond_c.c000077500000000000000000000171341325016550400175420ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_syrcond_x.c000077500000000000000000000165221325016550400175670ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_syrfsx_extended.c000077500000000000000000000573611325016550400210030ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_syrpvgrw.c000077500000000000000000000142511325016550400174570ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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__; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zla_wwaddw.c000077500000000000000000000104401325016550400170450ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zlabrd.c000077500000000000000000000214731325016550400161700ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray); } d = NA_PTR_TYPE(rblapack_d, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlacgv.c000077500000000000000000000056761325016550400162070ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlacn2.c000077500000000000000000000127231325016550400161010ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlacon.c000077500000000000000000000102301325016550400161650ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlacp2.c000077500000000000000000000071231325016550400161010ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlacpy.c000077500000000000000000000071231325016550400162100ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlacrm.c000077500000000000000000000077701325016550400162060ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } c = NA_PTR_TYPE(rblapack_c, doublecomplex*); rwork = ALLOC_N(doublereal, (2*m*n)); 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); } ruby-lapack-1.8.1/ext/zlacrt.c000077500000000000000000000113531325016550400162050ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zladiv.c000077500000000000000000000046141325016550400162010ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlaed0.c000077500000000000000000000157601325016550400160730ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaed7.c000077500000000000000000000364611325016550400161030ustar00rootroot00000000000000#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 occurrence 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray); } indxq = NA_PTR_TYPE(rblapack_indxq, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaed8.c000077500000000000000000000267371325016550400161110ustar00rootroot00000000000000#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 ); { na_shape_t shape[1]; shape[0] = n; rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray); } perm = NA_PTR_TYPE(rblapack_perm, integer*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaein.c000077500000000000000000000134471325016550400161760ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaesy.c000077500000000000000000000112051325016550400162110ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlaev2.c000077500000000000000000000102011325016550400161000ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlag2c.c000077500000000000000000000074331325016550400160740ustar00rootroot00000000000000#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 conversion 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlags2.c000077500000000000000000000127271325016550400161160ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlagtm.c000077500000000000000000000151771325016550400162140ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlahef.c000077500000000000000000000143761325016550400161670ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlahqr.c000077500000000000000000000214541325016550400162120ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlahr2.c000077500000000000000000000157221325016550400161140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlahrd.c000077500000000000000000000147721325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,nb); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaic1.c000077500000000000000000000120131325016550400160630ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlals0.c000077500000000000000000000317431325016550400161200ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlalsa.c000077500000000000000000000412311325016550400161720ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlalsd.c000077500000000000000000000213511325016550400161760ustar00rootroot00000000000000#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; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlangb.c000077500000000000000000000104501325016550400161600ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlange.c000077500000000000000000000076011325016550400161670ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlangt.c000077500000000000000000000107171325016550400162100ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlanhb.c000077500000000000000000000114011325016550400161560ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlanhe.c000077500000000000000000000111671325016550400161720ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlanhf.c000077500000000000000000000223661325016550400161760ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlanhp.c000077500000000000000000000110331325016550400161750ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlanhs.c000077500000000000000000000073351325016550400162120ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlanht.c000077500000000000000000000074641325016550400162160ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlansb.c000077500000000000000000000112501325016550400161730ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlansp.c000077500000000000000000000106371325016550400162210ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlansy.c000077500000000000000000000110101325016550400162140ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlantb.c000077500000000000000000000121651325016550400162020ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlantp.c000077500000000000000000000114211325016550400162120ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlantr.c000077500000000000000000000123341325016550400162200ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlapll.c000077500000000000000000000111711325016550400162020ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 1+(n-1)*incx; rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*); MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x)); rblapack_x = rblapack_x_out__; x = x_out__; { na_shape_t shape[1]; shape[0] = 1+(n-1)*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); } ruby-lapack-1.8.1/ext/zlapmr.c000077500000000000000000000104441325016550400162130ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlapmt.c000077500000000000000000000107131325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqgb.c000077500000000000000000000150541325016550400161700ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqge.c000077500000000000000000000134521325016550400161730ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlaqhb.c000077500000000000000000000125121325016550400161650ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqhe.c000077500000000000000000000124341325016550400161730ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlaqhp.c000077500000000000000000000120261325016550400162030ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqp2.c000077500000000000000000000175171325016550400161270ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MIN(m,n); rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqps.c000077500000000000000000000236541325016550400162270ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = kb; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqr0.c000077500000000000000000000262211325016550400161170ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqr1.c000077500000000000000000000070251325016550400161210ustar00rootroot00000000000000#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)); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqr2.c000077500000000000000000000264531325016550400161300ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqr3.c000077500000000000000000000261411325016550400161230ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = MAX(1,kbot); rblapack_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqr4.c000077500000000000000000000255731325016550400161340ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqr5.c000077500000000000000000000256631325016550400161350ustar00rootroot00000000000000#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; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqsb.c000077500000000000000000000131741325016550400162050ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqsp.c000077500000000000000000000120261325016550400162160ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlaqsy.c000077500000000000000000000124341325016550400162320ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID zlaqsy_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed); static VALUE rblapack_zlaqsy(int argc, VALUE *argv, VALUE self){ VALUE rblapack_uplo; char uplo; VALUE rblapack_a; doublecomplex *a; VALUE rblapack_s; doublereal *s; VALUE rblapack_scond; doublereal scond; VALUE rblapack_amax; doublereal amax; VALUE rblapack_equed; char equed; VALUE rblapack_a_out__; doublecomplex *a_out__; integer lda; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQSY equilibrates a symmetric matrix A using the scaling factors\n* in the vector S.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is stored.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the leading\n* n by n upper triangular part of A contains the upper\n* triangular part of the matrix A, and the strictly lower\n* triangular part of A is not referenced. If UPLO = 'L', the\n* leading n by n lower triangular part of A contains the lower\n* triangular part of the matrix A, and the strictly upper\n* triangular part of A is not referenced.\n*\n* On exit, if EQUED = 'Y', the equilibrated matrix:\n* diag(S) * A * diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* S (input) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) DOUBLE PRECISION\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies whether or not equilibration was done.\n* = 'N': No equilibration.\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if scaling should be done\n* based on the ratio of the scaling factors. If SCOND < THRESH,\n* scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if scaling should\n* be done based on the absolute size of the largest matrix element.\n* If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 5 && argc != 5) rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc); rblapack_uplo = argv[0]; rblapack_a = argv[1]; rblapack_s = argv[2]; rblapack_scond = argv[3]; rblapack_amax = argv[4]; if (argc == 5) { } else if (rblapack_options != Qnil) { } else { } uplo = StringValueCStr(rblapack_uplo)[0]; if (!NA_IsNArray(rblapack_s)) rb_raise(rb_eArgError, "s (3th argument) must be NArray"); if (NA_RANK(rblapack_s) != 1) rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1); n = NA_SHAPE0(rblapack_s); if (NA_TYPE(rblapack_s) != NA_DFLOAT) rblapack_s = na_change_type(rblapack_s, NA_DFLOAT); s = NA_PTR_TYPE(rblapack_s, doublereal*); amax = NUM2DBL(rblapack_amax); if (!NA_IsNArray(rblapack_a)) rb_raise(rb_eArgError, "a (2th argument) must be NArray"); if (NA_RANK(rblapack_a) != 2) rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2); lda = NA_SHAPE0(rblapack_a); if (NA_SHAPE1(rblapack_a) != n) rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s"); if (NA_TYPE(rblapack_a) != NA_DCOMPLEX) rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX); a = NA_PTR_TYPE(rblapack_a, doublecomplex*); scond = NUM2DBL(rblapack_scond); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; zlaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed); rblapack_equed = rb_str_new(&equed,1); return rb_ary_new3(2, rblapack_equed, rblapack_a); } void init_lapack_zlaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "zlaqsy", rblapack_zlaqsy, -1); } ruby-lapack-1.8.1/ext/zlar1v.c000077500000000000000000000255761325016550400161410ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID zlar1v_(integer* n, integer* b1, integer* bn, doublereal* lambda, doublereal* d, doublereal* l, doublereal* ld, doublereal* lld, doublereal* pivmin, doublereal* gaptol, doublecomplex* z, logical* wantnc, integer* negcnt, doublereal* ztz, doublereal* mingma, integer* r, integer* isuppz, doublereal* nrminv, doublereal* resid, doublereal* rqcorr, doublereal* work); static VALUE rblapack_zlar1v(int argc, VALUE *argv, VALUE self){ VALUE rblapack_b1; integer b1; VALUE rblapack_bn; integer bn; VALUE rblapack_lambda; doublereal lambda; VALUE rblapack_d; doublereal *d; VALUE rblapack_l; doublereal *l; VALUE rblapack_ld; doublereal *ld; VALUE rblapack_lld; doublereal *lld; VALUE rblapack_pivmin; doublereal pivmin; VALUE rblapack_gaptol; doublereal gaptol; VALUE rblapack_z; doublecomplex *z; VALUE rblapack_wantnc; logical wantnc; VALUE rblapack_r; integer r; VALUE rblapack_negcnt; integer negcnt; VALUE rblapack_ztz; doublereal ztz; VALUE rblapack_mingma; doublereal mingma; VALUE rblapack_isuppz; integer *isuppz; VALUE rblapack_nrminv; doublereal nrminv; VALUE rblapack_resid; doublereal resid; VALUE rblapack_rqcorr; doublereal rqcorr; VALUE rblapack_z_out__; doublecomplex *z_out__; doublereal *work; integer n; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.zlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n* Purpose\n* =======\n*\n* ZLAR1V computes the (scaled) r-th column of the inverse of\n* the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n* L D L^T - sigma I. When sigma is close to an eigenvalue, the\n* computed vector is an accurate eigenvector. Usually, r corresponds\n* to the index where the eigenvector is largest in magnitude.\n* The following steps accomplish this computation :\n* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,\n* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n* (c) Computation of the diagonal elements of the inverse of\n* L D L^T - sigma I by combining the above transforms, and choosing\n* r as the index where the diagonal of the inverse is (one of the)\n* largest in magnitude.\n* (d) Computation of the (scaled) r-th column of the inverse using the\n* twisted factorization obtained by combining the top part of the\n* the stationary and the bottom part of the progressive transform.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix L D L^T.\n*\n* B1 (input) INTEGER\n* First index of the submatrix of L D L^T.\n*\n* BN (input) INTEGER\n* Last index of the submatrix of L D L^T.\n*\n* LAMBDA (input) DOUBLE PRECISION\n* The shift. In order to compute an accurate eigenvector,\n* LAMBDA should be a good approximation to an eigenvalue\n* of L D L^T.\n*\n* L (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal matrix\n* L, in elements 1 to N-1.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D.\n*\n* LD (input) DOUBLE PRECISION array, dimension (N-1)\n* The n-1 elements L(i)*D(i).\n*\n* LLD (input) DOUBLE PRECISION array, dimension (N-1)\n* The n-1 elements L(i)*L(i)*D(i).\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence.\n*\n* GAPTOL (input) DOUBLE PRECISION\n* Tolerance that indicates when eigenvector entries are negligible\n* w.r.t. their contribution to the residual.\n*\n* Z (input/output) COMPLEX*16 array, dimension (N)\n* On input, all entries of Z must be set to 0.\n* On output, Z contains the (scaled) r-th column of the\n* inverse. The scaling is such that Z(R) equals 1.\n*\n* WANTNC (input) LOGICAL\n* Specifies whether NEGCNT has to be computed.\n*\n* NEGCNT (output) INTEGER\n* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n*\n* ZTZ (output) DOUBLE PRECISION\n* The square of the 2-norm of Z.\n*\n* MINGMA (output) DOUBLE PRECISION\n* The reciprocal of the largest (in magnitude) diagonal\n* element of the inverse of L D L^T - sigma I.\n*\n* R (input/output) INTEGER\n* The twist index for the twisted factorization used to\n* compute Z.\n* On input, 0 <= R <= N. If R is input as 0, R is set to\n* the index where (L D L^T - sigma I)^{-1} is largest\n* in magnitude. If 1 <= R <= N, R is unchanged.\n* On output, R contains the twist index used to compute Z.\n* Ideally, R designates the position of the maximum entry in the\n* eigenvector.\n*\n* ISUPPZ (output) INTEGER array, dimension (2)\n* The support of the vector in Z, i.e., the vector Z is\n* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n*\n* NRMINV (output) DOUBLE PRECISION\n* NRMINV = 1/SQRT( ZTZ )\n*\n* RESID (output) DOUBLE PRECISION\n* The residual of the FP vector.\n* RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n* RQCORR (output) DOUBLE PRECISION\n* The Rayleigh Quotient correction to LAMBDA.\n* RQCORR = MINGMA*TMP\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Beresford Parlett, University of California, Berkeley, USA\n* Jim Demmel, University of California, Berkeley, USA\n* Inderjit Dhillon, University of Texas, Austin, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, University of California, Berkeley, USA\n*\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.zlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 12 && argc != 12) rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc); rblapack_b1 = argv[0]; rblapack_bn = argv[1]; rblapack_lambda = argv[2]; rblapack_d = argv[3]; rblapack_l = argv[4]; rblapack_ld = argv[5]; rblapack_lld = argv[6]; rblapack_pivmin = argv[7]; rblapack_gaptol = argv[8]; rblapack_z = argv[9]; rblapack_wantnc = argv[10]; rblapack_r = argv[11]; if (argc == 12) { } else if (rblapack_options != Qnil) { } else { } b1 = NUM2INT(rblapack_b1); lambda = NUM2DBL(rblapack_lambda); pivmin = NUM2DBL(rblapack_pivmin); if (!NA_IsNArray(rblapack_z)) rb_raise(rb_eArgError, "z (10th argument) must be NArray"); if (NA_RANK(rblapack_z) != 1) rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1); n = NA_SHAPE0(rblapack_z); if (NA_TYPE(rblapack_z) != NA_DCOMPLEX) rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX); z = NA_PTR_TYPE(rblapack_z, doublecomplex*); r = NUM2INT(rblapack_r); bn = NUM2INT(rblapack_bn); gaptol = NUM2DBL(rblapack_gaptol); if (!NA_IsNArray(rblapack_d)) rb_raise(rb_eArgError, "d (4th argument) must be NArray"); if (NA_RANK(rblapack_d) != 1) rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1); if (NA_SHAPE0(rblapack_d) != n) rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z"); if (NA_TYPE(rblapack_d) != NA_DFLOAT) rblapack_d = na_change_type(rblapack_d, NA_DFLOAT); d = NA_PTR_TYPE(rblapack_d, doublereal*); if (!NA_IsNArray(rblapack_ld)) rb_raise(rb_eArgError, "ld (6th argument) must be NArray"); if (NA_RANK(rblapack_ld) != 1) rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1); if (NA_SHAPE0(rblapack_ld) != (n-1)) rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1); if (NA_TYPE(rblapack_ld) != NA_DFLOAT) rblapack_ld = na_change_type(rblapack_ld, NA_DFLOAT); ld = NA_PTR_TYPE(rblapack_ld, doublereal*); wantnc = (rblapack_wantnc == Qtrue); if (!NA_IsNArray(rblapack_l)) rb_raise(rb_eArgError, "l (5th argument) must be NArray"); if (NA_RANK(rblapack_l) != 1) rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1); if (NA_SHAPE0(rblapack_l) != (n-1)) rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1); if (NA_TYPE(rblapack_l) != NA_DFLOAT) rblapack_l = na_change_type(rblapack_l, NA_DFLOAT); l = NA_PTR_TYPE(rblapack_l, doublereal*); if (!NA_IsNArray(rblapack_lld)) rb_raise(rb_eArgError, "lld (7th argument) must be NArray"); if (NA_RANK(rblapack_lld) != 1) rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1); if (NA_SHAPE0(rblapack_lld) != (n-1)) rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1); if (NA_TYPE(rblapack_lld) != NA_DFLOAT) rblapack_lld = na_change_type(rblapack_lld, NA_DFLOAT); lld = NA_PTR_TYPE(rblapack_lld, doublereal*); { na_shape_t shape[1]; shape[0] = 2; rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray); } isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*); { na_shape_t shape[1]; shape[0] = n; rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*); MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z)); rblapack_z = rblapack_z_out__; z = z_out__; work = ALLOC_N(doublereal, (4*n)); zlar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work); free(work); rblapack_negcnt = INT2NUM(negcnt); rblapack_ztz = rb_float_new((double)ztz); rblapack_mingma = rb_float_new((double)mingma); rblapack_nrminv = rb_float_new((double)nrminv); rblapack_resid = rb_float_new((double)resid); rblapack_rqcorr = rb_float_new((double)rqcorr); rblapack_r = INT2NUM(r); return rb_ary_new3(9, rblapack_negcnt, rblapack_ztz, rblapack_mingma, rblapack_isuppz, rblapack_nrminv, rblapack_resid, rblapack_rqcorr, rblapack_z, rblapack_r); } void init_lapack_zlar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "zlar1v", rblapack_zlar1v, -1); } ruby-lapack-1.8.1/ext/zlar2v.c000077500000000000000000000157731325016550400161400ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID zlar2v_(integer* n, doublecomplex* x, doublecomplex* y, doublecomplex* z, integer* incx, doublereal* c, doublecomplex* s, integer* incc); static VALUE rblapack_zlar2v(int argc, VALUE *argv, VALUE self){ VALUE rblapack_n; integer n; VALUE rblapack_x; doublecomplex *x; VALUE rblapack_y; doublecomplex *y; VALUE rblapack_z; doublecomplex *z; VALUE rblapack_incx; integer incx; VALUE rblapack_c; doublereal *c; VALUE rblapack_s; doublecomplex *s; VALUE rblapack_incc; integer incc; VALUE rblapack_x_out__; doublecomplex *x_out__; VALUE rblapack_y_out__; doublecomplex *y_out__; VALUE rblapack_z_out__; doublecomplex *z_out__; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* ZLAR2V applies a vector of complex plane rotations with real cosines\n* from both sides to a sequence of 2-by-2 complex Hermitian matrices,\n* defined by the elements of the vectors x, y and z. For i = 1,2,...,n\n*\n* ( x(i) z(i) ) :=\n* ( conjg(z(i)) y(i) )\n*\n* ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) )\n* ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) )\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be applied.\n*\n* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* The vector x; the elements of x are assumed to be real.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* The vector y; the elements of y are assumed to be real.\n*\n* Z (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* The vector z.\n*\n* INCX (input) INTEGER\n* The increment between elements of X, Y and Z. INCX > 0.\n*\n* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)\n* The sines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C and S. INCC > 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IC, IX\n DOUBLE PRECISION CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n $ ZIR\n COMPLEX*16 SI, T2, T3, T4, ZI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG\n* ..\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 8 && argc != 8) rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc); rblapack_n = argv[0]; rblapack_x = argv[1]; rblapack_y = argv[2]; rblapack_z = argv[3]; rblapack_incx = argv[4]; rblapack_c = argv[5]; rblapack_s = argv[6]; rblapack_incc = argv[7]; if (argc == 8) { } else if (rblapack_options != Qnil) { } else { } n = NUM2INT(rblapack_n); incx = NUM2INT(rblapack_incx); incc = NUM2INT(rblapack_incc); if (!NA_IsNArray(rblapack_x)) rb_raise(rb_eArgError, "x (2th argument) must be NArray"); if (NA_RANK(rblapack_x) != 1) rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1); if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx)) rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx); if (NA_TYPE(rblapack_x) != NA_DCOMPLEX) rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX); x = NA_PTR_TYPE(rblapack_x, doublecomplex*); if (!NA_IsNArray(rblapack_z)) rb_raise(rb_eArgError, "z (4th argument) must be NArray"); if (NA_RANK(rblapack_z) != 1) rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1); if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx)) rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx); if (NA_TYPE(rblapack_z) != NA_DCOMPLEX) rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX); z = NA_PTR_TYPE(rblapack_z, doublecomplex*); if (!NA_IsNArray(rblapack_s)) rb_raise(rb_eArgError, "s (7th argument) must be NArray"); if (NA_RANK(rblapack_s) != 1) rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1); if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc)) rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc); if (NA_TYPE(rblapack_s) != NA_DCOMPLEX) rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX); s = NA_PTR_TYPE(rblapack_s, doublecomplex*); if (!NA_IsNArray(rblapack_y)) rb_raise(rb_eArgError, "y (3th argument) must be NArray"); if (NA_RANK(rblapack_y) != 1) rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1); if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx)) rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx); if (NA_TYPE(rblapack_y) != NA_DCOMPLEX) rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX); y = NA_PTR_TYPE(rblapack_y, doublecomplex*); if (!NA_IsNArray(rblapack_c)) rb_raise(rb_eArgError, "c (6th argument) must be NArray"); if (NA_RANK(rblapack_c) != 1) rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1); if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc)) rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc); if (NA_TYPE(rblapack_c) != NA_DFLOAT) rblapack_c = na_change_type(rblapack_c, NA_DFLOAT); c = NA_PTR_TYPE(rblapack_c, doublereal*); { na_shape_t shape[1]; shape[0] = 1+(n-1)*incx; rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*); MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x)); rblapack_x = rblapack_x_out__; x = x_out__; { na_shape_t shape[1]; shape[0] = 1+(n-1)*incx; rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*); MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y)); rblapack_y = rblapack_y_out__; y = y_out__; { na_shape_t shape[1]; shape[0] = 1+(n-1)*incx; rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*); MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z)); rblapack_z = rblapack_z_out__; z = z_out__; zlar2v_(&n, x, y, z, &incx, c, s, &incc); return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z); } void init_lapack_zlar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "zlar2v", rblapack_zlar2v, -1); } ruby-lapack-1.8.1/ext/zlarcm.c000077500000000000000000000075321325016550400162020ustar00rootroot00000000000000#include "rb_lapack.h" extern VOID zlarcm_(integer* m, integer* n, doublereal* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* rwork); static VALUE rblapack_zlarcm(int argc, VALUE *argv, VALUE self){ VALUE rblapack_a; doublereal *a; VALUE rblapack_b; doublecomplex *b; VALUE rblapack_c; doublecomplex *c; doublereal *rwork; integer lda; integer m; integer ldb; integer n; integer ldc; VALUE rblapack_options; if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) { argc--; rblapack_options = argv[argc]; if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) { printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarcm( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* ZLARCM performs a very simple matrix-matrix multiplication:\n* C := A * B,\n* where A is M by M and real; B is M by N and complex;\n* C is M by N and complex.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A and of the matrix C.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns and rows of the matrix B and\n* the number of columns of the matrix C.\n* N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA, M)\n* A contains the M by M matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >=max(1,M).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB, N)\n* B contains the M by N matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >=max(1,M).\n*\n* C (input) COMPLEX*16 array, dimension (LDC, N)\n* C contains the M by N matrix C.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >=max(1,M).\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n*\n\n* =====================================================================\n*\n\n"); return Qnil; } if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) { printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarcm( a, b, [:usage => usage, :help => help])\n"); return Qnil; } } else rblapack_options = Qnil; if (argc != 2 && argc != 2) rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc); rblapack_a = argv[0]; rblapack_b = argv[1]; if (argc == 2) { } else if (rblapack_options != Qnil) { } else { } if (!NA_IsNArray(rblapack_a)) rb_raise(rb_eArgError, "a (1th argument) must be NArray"); if (NA_RANK(rblapack_a) != 2) rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2); lda = NA_SHAPE0(rblapack_a); m = NA_SHAPE1(rblapack_a); if (NA_TYPE(rblapack_a) != NA_DFLOAT) rblapack_a = na_change_type(rblapack_a, NA_DFLOAT); a = NA_PTR_TYPE(rblapack_a, doublereal*); ldc = MAX(1,m); if (!NA_IsNArray(rblapack_b)) rb_raise(rb_eArgError, "b (2th argument) must be NArray"); if (NA_RANK(rblapack_b) != 2) rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2); ldb = NA_SHAPE0(rblapack_b); n = NA_SHAPE1(rblapack_b); if (NA_TYPE(rblapack_b) != NA_DCOMPLEX) rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX); b = NA_PTR_TYPE(rblapack_b, doublecomplex*); { na_shape_t shape[2]; shape[0] = ldc; shape[1] = n; rblapack_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } c = NA_PTR_TYPE(rblapack_c, doublecomplex*); rwork = ALLOC_N(doublereal, (2*m*n)); zlarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork); free(rwork); return rblapack_c; } void init_lapack_zlarcm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){ sHelp = sH; sUsage = sU; rblapack_ZERO = zero; rb_define_module_function(mLapack, "zlarcm", rblapack_zlarcm, -1); } ruby-lapack-1.8.1/ext/zlarf.c000077500000000000000000000117371325016550400160320ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarfb.c000077500000000000000000000152211325016550400161640ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarfg.c000077500000000000000000000103721325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarfgp.c000077500000000000000000000103261325016550400163520ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarft.c000077500000000000000000000155061325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarfx.c000077500000000000000000000110261325016550400162110ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlargv.c000077500000000000000000000125611325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = 1+(n-1)*incx; rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*); MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x)); rblapack_x = rblapack_x_out__; x = x_out__; { na_shape_t shape[1]; shape[0] = 1+(n-1)*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); } ruby-lapack-1.8.1/ext/zlarnv.c000077500000000000000000000076511325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,n); rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x = NA_PTR_TYPE(rblapack_x, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarrv.c000077500000000000000000000416441325016550400162340ustar00rootroot00000000000000#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 split.) 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 occurred 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*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarscl2.c000077500000000000000000000067521325016550400164510ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zlartg.c000077500000000000000000000064451325016550400162170ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlartv.c000077500000000000000000000135041325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = 1+(n-1)*incx; rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*); MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x)); rblapack_x = rblapack_x_out__; x = x_out__; { na_shape_t shape[1]; shape[0] = 1+(n-1)*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); } ruby-lapack-1.8.1/ext/zlarz.c000077500000000000000000000126661325016550400160600ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarzb.c000077500000000000000000000156341325016550400162200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlarzt.c000077500000000000000000000167261325016550400162450ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlascl.c000077500000000000000000000123311325016550400161730ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlascl2.c000077500000000000000000000067171325016550400162700ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t 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; #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zlaset.c000077500000000000000000000104311325016550400162040ustar00rootroot00000000000000#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)); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlasr.c000077500000000000000000000207051325016550400160420ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlassq.c000077500000000000000000000072561325016550400162320ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zlaswp.c000077500000000000000000000107721325016550400162320ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlasyf.c000077500000000000000000000143641325016550400162230ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlat2c.c000077500000000000000000000100521325016550400161000ustar00rootroot00000000000000#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 conversion 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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlatbs.c000077500000000000000000000252151325016550400162070ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlatdf.c000077500000000000000000000202461325016550400161730ustar00rootroot00000000000000#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 chosen 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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlatps.c000077500000000000000000000243711325016550400162270ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlatrd.c000077500000000000000000000176521325016550400162160ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n-1; rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray); } e = NA_PTR_TYPE(rblapack_e, doublereal*); { na_shape_t shape[1]; shape[0] = n-1; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlatrs.c000077500000000000000000000251451325016550400162310ustar00rootroot00000000000000#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]; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlatrz.c000077500000000000000000000120621325016550400162320ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlatzm.c000077500000000000000000000165071325016550400162350ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zlauu2.c000077500000000000000000000074061325016550400161340ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zlauum.c000077500000000000000000000074041325016550400162250ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zpbcon.c000077500000000000000000000112031325016550400161730ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zpbequ.c000077500000000000000000000115611325016550400162150ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbrfs.c000077500000000000000000000207231325016550400162150ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbstf.c000077500000000000000000000131111325016550400162100ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbsv.c000077500000000000000000000161111325016550400160470ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbsvx.c000077500000000000000000000406101325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbtf2.c000077500000000000000000000123431325016550400161150ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbtrf.c000077500000000000000000000121761325016550400162210ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpbtrs.c000077500000000000000000000122361325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpftrf.c000077500000000000000000000205601325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpftri.c000077500000000000000000000201771325016550400162300ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpftrs.c000077500000000000000000000205221325016550400162340ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpocon.c000077500000000000000000000100051325016550400162070ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zpoequ.c000077500000000000000000000101221325016550400162220ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpoequb.c000077500000000000000000000101341325016550400163670ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zporfs.c000077500000000000000000000202041325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zporfsx.c000077500000000000000000000506371325016550400164310ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zposv.c000077500000000000000000000135621325016550400160730ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zposvx.c000077500000000000000000000366161325016550400162700ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zposvxx.c000077500000000000000000000630611325016550400164520ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zpotf2.c000077500000000000000000000101311325016550400161230ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zpotrf.c000077500000000000000000000100121325016550400162210ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zpotri.c000077500000000000000000000074041325016550400162370ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zpotrs.c000077500000000000000000000103021325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zppcon.c000077500000000000000000000102461325016550400162170ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zppequ.c000077500000000000000000000106671325016550400162410ustar00rootroot00000000000000#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; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpprfs.c000077500000000000000000000176351325016550400162430ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zppsv.c000077500000000000000000000144401325016550400160700ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zppsvx.c000077500000000000000000000367561325016550400162760ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpptrf.c000077500000000000000000000105731325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpptri.c000077500000000000000000000074041325016550400162400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpptrs.c000077500000000000000000000114761325016550400162560ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpstf2.c000077500000000000000000000126551325016550400161440ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zpstrf.c000077500000000000000000000126531325016550400162420ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray); } piv = NA_PTR_TYPE(rblapack_piv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zptcon.c000077500000000000000000000105441325016550400162240ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zpteqr.c000077500000000000000000000166661325016550400162470ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zptrfs.c000077500000000000000000000216351325016550400162420ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zptsv.c000077500000000000000000000142171325016550400160760ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zptsvx.c000077500000000000000000000270741325016550400162730ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpttrf.c000077500000000000000000000105221325016550400162340ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zpttrs.c000077500000000000000000000132471325016550400162600ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zptts2.c000077500000000000000000000123511325016550400161530ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zrot.c000077500000000000000000000113311325016550400157000ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zspcon.c000077500000000000000000000111051325016550400162150ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zspmv.c000077500000000000000000000161471325016550400160730ustar00rootroot00000000000000#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)); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zspr.c000077500000000000000000000136041325016550400157050ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsprfs.c000077500000000000000000000211371325016550400162360ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zspsv.c000077500000000000000000000165061325016550400161000ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zspsvx.c000077500000000000000000000322131325016550400162610ustar00rootroot00000000000000#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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsptrf.c000077500000000000000000000150311325016550400162330ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsptri.c000077500000000000000000000112071325016550400162370ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsptrs.c000077500000000000000000000117261325016550400162570ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zstedc.c000077500000000000000000000300471325016550400162030ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lrwork); rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray); } rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zstegr.c000077500000000000000000000306451325016550400162310ustar00rootroot00000000000000#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 compatibility 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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zstein.c000077500000000000000000000206461325016550400162270ustar00rootroot00000000000000#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); { na_shape_t 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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zstemr.c000077500000000000000000000411041325016550400162270ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsteqr.c000077500000000000000000000155271325016550400162450ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsycon.c000077500000000000000000000112431325016550400162310ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zsyconv.c000077500000000000000000000107261325016550400164240ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/zsyequb.c000077500000000000000000000116761325016550400164200ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsymv.c000077500000000000000000000160331325016550400160760ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsyr.c000077500000000000000000000132571325016550400157220ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsyrfs.c000077500000000000000000000217301325016550400162460ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsyrfsx.c000077500000000000000000000523311325016550400164370ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zsysv.c000077500000000000000000000204711325016550400161050ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsysvx.c000077500000000000000000000337641325016550400163060ustar00rootroot00000000000000#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); } { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsysvxx.c000077500000000000000000000655761325016550400165040ustar00rootroot00000000000000#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){ #ifdef USEXBLAS 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 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*); { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } berr = NA_PTR_TYPE(rblapack_berr, doublereal*); { na_shape_t 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*); { na_shape_t 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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); #else return Qnil; #endif } 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); } ruby-lapack-1.8.1/ext/zsyswapr.c000077500000000000000000000077441325016550400166210ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsytf2.c000077500000000000000000000160751325016550400161550ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsytrf.c000077500000000000000000000202361325016550400162470ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = n; rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray); } ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsytri.c000077500000000000000000000113511325016550400162500ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsytri2.c000077500000000000000000000140171325016550400163340ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsytri2x.c000077500000000000000000000117031325016550400165230ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zsytrs.c000077500000000000000000000120441325016550400162620ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zsytrs2.c000077500000000000000000000123231325016550400163440ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztbcon.c000077500000000000000000000115531325016550400162070ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ztbrfs.c000077500000000000000000000173011325016550400162170ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztbtrs.c000077500000000000000000000132631325016550400162400ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztfsm.c000077500000000000000000000265551325016550400160630ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztftri.c000077500000000000000000000205521325016550400162310ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztfttp.c000077500000000000000000000167671325016550400162570ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztfttr.c000077500000000000000000000172541325016550400162510ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgevc.c000077500000000000000000000247471325016550400162230ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgex2.c000077500000000000000000000227021325016550400161310ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgexc.c000077500000000000000000000246041325016550400162150ustar00rootroot00000000000000#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); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgsen.c000077500000000000000000000526351325016550400162300ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*); { na_shape_t shape[1]; shape[0] = 2; rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, doublereal*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,liwork); rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray); } iwork = NA_PTR_TYPE(rblapack_iwork, integer*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgsja.c000077500000000000000000000401211325016550400162030ustar00rootroot00000000000000#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); { na_shape_t shape[1]; shape[0] = n; rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray); } alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*); { na_shape_t shape[1]; shape[0] = n; rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } beta = NA_PTR_TYPE(rblapack_beta, doublereal*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgsna.c000077500000000000000000000330661325016550400162210ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t shape[1]; shape[0] = mm; rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray); } dif = NA_PTR_TYPE(rblapack_dif, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgsy2.c000077500000000000000000000305021325016550400161450ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztgsyl.c000077500000000000000000000336071325016550400162500ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztpcon.c000077500000000000000000000107141325016550400162230ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ztprfs.c000077500000000000000000000165131325016550400162410ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztptri.c000077500000000000000000000110041325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztptrs.c000077500000000000000000000124561325016550400162610ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztpttf.c000077500000000000000000000167771325016550400162600ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztpttr.c000077500000000000000000000074441325016550400162630ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrcon.c000077500000000000000000000112521325016550400162230ustar00rootroot00000000000000#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); } ruby-lapack-1.8.1/ext/ztrevc.c000077500000000000000000000243461325016550400162310ustar00rootroot00000000000000#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*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrexc.c000077500000000000000000000134141325016550400162250ustar00rootroot00000000000000#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); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrrfs.c000077500000000000000000000170001325016550400162330ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = nrhs; rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray); } ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrsen.c000077500000000000000000000277521325016550400162450ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = n; rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } w = NA_PTR_TYPE(rblapack_w, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrsna.c000077500000000000000000000245551325016550400162370ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = mm; rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray); } s = NA_PTR_TYPE(rblapack_s, doublereal*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrsyl.c000077500000000000000000000144311325016550400162550ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrti2.c000077500000000000000000000101311325016550400161350ustar00rootroot00000000000000#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]; { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/ztrtri.c000077500000000000000000000101601325016550400162370ustar00rootroot00000000000000#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]; { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/ztrtrs.c000077500000000000000000000127641325016550400162650ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrttf.c000077500000000000000000000171641325016550400162510ustar00rootroot00000000000000#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]; { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztrttp.c000077500000000000000000000073501325016550400162570ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/ztzrqf.c000077500000000000000000000116401325016550400162450ustar00rootroot00000000000000#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; { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/ztzrzf.c000077500000000000000000000142221325016550400162550ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = m; rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zunbdb.c000077500000000000000000000352221325016550400161730ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = q; rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray); } theta = NA_PTR_TYPE(rblapack_theta, doublereal*); { na_shape_t shape[1]; shape[0] = q-1; rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray); } phi = NA_PTR_TYPE(rblapack_phi, doublereal*); { na_shape_t shape[1]; shape[0] = p; rblapack_taup1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taup1 = NA_PTR_TYPE(rblapack_taup1, doublecomplex*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_taup2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } taup2 = NA_PTR_TYPE(rblapack_taup2, doublecomplex*); { na_shape_t shape[1]; shape[0] = q; rblapack_tauq1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublecomplex*); { na_shape_t shape[1]; shape[0] = m-q; rblapack_tauq2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublecomplex*); { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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__; { na_shape_t 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); } ruby-lapack-1.8.1/ext/zuncsd.c000077500000000000000000000314601325016550400162150ustar00rootroot00000000000000#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; { na_shape_t 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*); { na_shape_t shape[1]; shape[0] = p; rblapack_u1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } u1 = NA_PTR_TYPE(rblapack_u1, doublecomplex*); { na_shape_t shape[1]; shape[0] = m-p; rblapack_u2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } u2 = NA_PTR_TYPE(rblapack_u2, doublecomplex*); { na_shape_t shape[1]; shape[0] = q; rblapack_v1t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } v1t = NA_PTR_TYPE(rblapack_v1t, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zung2l.c000077500000000000000000000105351325016550400161300ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zung2r.c000077500000000000000000000105311325016550400161320ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungbr.c000077500000000000000000000156231325016550400162210ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zunghr.c000077500000000000000000000130201325016550400162140ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungl2.c000077500000000000000000000103741325016550400161310ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zunglq.c000077500000000000000000000125751325016550400162350ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungql.c000077500000000000000000000126321325016550400162270ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungqr.c000077500000000000000000000126261325016550400162400ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungr2.c000077500000000000000000000104141325016550400161320ustar00rootroot00000000000000#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*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungrq.c000077500000000000000000000126141325016550400162350ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zungtr.c000077500000000000000000000125631325016550400162430ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t shape[2]; shape[0] = lda; shape[1] = n; rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray); } a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*); MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a)); rblapack_a = rblapack_a_out__; a = a_out__; 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); } ruby-lapack-1.8.1/ext/zunm2l.c000077500000000000000000000144551325016550400161430ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunm2r.c000077500000000000000000000144561325016550400161520ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmbr.c000077500000000000000000000224331325016550400162240ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmhr.c000077500000000000000000000202741325016550400162330ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunml2.c000077500000000000000000000142451325016550400161400ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmlq.c000077500000000000000000000162731325016550400162420ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmql.c000077500000000000000000000164731325016550400162440ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmqr.c000077500000000000000000000165061325016550400162470ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmr2.c000077500000000000000000000142441325016550400161450ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmr3.c000077500000000000000000000160751325016550400161520ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmrq.c000077500000000000000000000162621325016550400162460ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmrz.c000077500000000000000000000172331325016550400162560ustar00rootroot00000000000000#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); } { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zunmtr.c000077500000000000000000000176421325016550400162540ustar00rootroot00000000000000#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*); { na_shape_t shape[1]; shape[0] = MAX(1,lwork); rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray); } work = NA_PTR_TYPE(rblapack_work, doublecomplex*); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zupgtr.c000077500000000000000000000104051325016550400162360ustar00rootroot00000000000000#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); { na_shape_t 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); } ruby-lapack-1.8.1/ext/zupmtr.c000077500000000000000000000146361325016550400162560ustar00rootroot00000000000000#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*); { na_shape_t 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); } ruby-lapack-1.8.1/lib/000077500000000000000000000000001325016550400145025ustar00rootroot00000000000000ruby-lapack-1.8.1/lib/numru/000077500000000000000000000000001325016550400156505ustar00rootroot00000000000000ruby-lapack-1.8.1/lib/numru/lapack.rb000077500000000000000000000017061325016550400174370ustar00rootroot00000000000000begin require "rubygems" rescue LoadError end 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 ruby-lapack-1.8.1/samples/000077500000000000000000000000001325016550400154005ustar00rootroot00000000000000ruby-lapack-1.8.1/samples/dpotrf.rb000077500000000000000000000007171325016550400172330ustar00rootroot00000000000000require "numru/lapack" uplo = "L" p a = NArray[[ 4.16, -3.12, 0.56, -0.10], [-3.12, 5.03, -0.83, 1.18], [ 0.56, -0.83, 0.76, 0.34], [-0.10, 1.18, 0.34, 1.18]] a_org = a.dup info, a = NumRu::Lapack.dpotrf(uplo, a) p info p a for i in 0...a.shape[0] for j in 0...i a[j,i] = 0.0 end end a = NMatrix.ref(a) if (NArray.ref(a.transpose * a) - a_org).abs.gt(1.0e-10).count_true == 0 p "OK" else p "NG" end ruby-lapack-1.8.1/samples/dsyevr.rb000077500000000000000000000006251325016550400172470ustar00rootroot00000000000000require "numru/lapack" jobz = "V" range = "I" uplo = "U" a = NArray[[1,1,0], [1,2,1], [0,1,1]] vl = vu = 0 # not be used in this example il = 1 iu = 3 abstol = 0.0 lwork = 78 liwork = 30 m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr(jobz, range, uplo, a, vl, vu, il, iu, abstol, :lwork => lwork, :liwork => liwork) p m p w p z p isuppz p work p iwork p info p a ruby-lapack-1.8.1/tests/000077500000000000000000000000001325016550400150765ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/eig/000077500000000000000000000000001325016550400156425ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/eig/ge/000077500000000000000000000000001325016550400162355ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/eig/ge/test_gesdd.rb000077500000000000000000000101631325016550400207130ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/eig/ge/test_gesvd.rb000077500000000000000000000105301325016550400207330ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/eig/gg/000077500000000000000000000000001325016550400162375ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/eig/gg/test_ggev.rb000077500000000000000000000122201325016550400205530ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/eig/gg/test_ggsvd.rb000077500000000000000000000102601325016550400207370ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/eig/sb/000077500000000000000000000000001325016550400162465ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/eig/sb/test_sbev.rb000077500000000000000000000023731325016550400206010ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lapack_test.rb000077500000000000000000000020011325016550400177110ustar00rootroot00000000000000$:.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 = < 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 ruby-lapack-1.8.1/tests/lin/000077500000000000000000000000001325016550400156605ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/lin/gb/000077500000000000000000000000001325016550400162505ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/lin/gb/test_gbsv.rb000077500000000000000000000027031325016550400206020ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/gb/test_gbsvx.rb000077500000000000000000000037021325016550400207720ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/ge/000077500000000000000000000000001325016550400162535ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/lin/ge/test_gels.rb000077500000000000000000000045351325016550400206030ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/ge/test_gelsd.rb000077500000000000000000000037511325016550400207460ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/ge/test_gelss.rb000077500000000000000000000053231325016550400207620ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/ge/test_gelsy.rb000077500000000000000000000052461325016550400207740ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/ge/test_gesv.rb000077500000000000000000000025641325016550400206150ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/ge/test_gesvx.rb000077500000000000000000000035641325016550400210060ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/gt/000077500000000000000000000000001325016550400162725ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/lin/gt/test_gtsv.rb000077500000000000000000000022051325016550400206430ustar00rootroot00000000000000$:.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 ruby-lapack-1.8.1/tests/lin/sy/000077500000000000000000000000001325016550400163135ustar00rootroot00000000000000ruby-lapack-1.8.1/tests/lin/sy/test_sysv.rb000077500000000000000000000042711325016550400207120ustar00rootroot00000000000000$:.push File.dirname(__FILE__) + "/../.." require "lapack_test" class SysvTest < 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.81, 2.06, 0.63, -1.15], [ 2.06, 1.15, 1.87, 4.20], [ 0.63, 1.87, -0.21, 3.87], [-1.15, 4.20, 3.87, 2.07]].to_lm @b[:r] = NVector[[0.96, 6.07, 8.38, 9.50]] @b_exp[:r] = NArray[[-5.0, -2.0, 1.0, 4.0]] @ipiv_exp[:r] = NArray[1, 2, -2, -2] @a[:c] = NMatrix[[-0.56+0.12*I, -1.54-2.86*I, 5.32-1.59*I, 3.80+0.92*I], [-1.54-2.86*I, -2.83-0.03*I, -3.52+0.58*I, -7.86-2.96*I], [ 5.32-1.59*I, -3.52+0.58*I, 8.86+1.81*I, 5.14-0.64*I], [ 3.80+0.92*I, -7.86-2.96*I, 5.14-0.64*I, -0.39-0.71*I]].to_lm @b[:c] = NVector[[-6.43+19.24*I, -0.49-1.47*I, -48.18+66.0*I, -55.64+41.22*I]] @b_exp[:c] = NArray[[-4.0+3.0*I, 3.0-2.0*I, -2.0+5.0*I, 1.0-1.0*I]] @ipiv_exp[:c] = NArray[1, 2, -2, -2] end %w(s d c z).each do |x| method = "#{x}sysv" rc = LapackTest.get_rc(x) define_method("test_#{method}") do ipiv, work, info, a, b = NumRu::Lapack.send(method, "U", @a[rc], @b[rc]) assert_equal 0, info assert_narray @b_exp[rc], b assert_narray @ipiv_exp[rc], ipiv end define_method("test_#{method}_inquiring_lwork") do rank, work, info, = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], :lwork => -1) assert_equal 0, info lwork = get_int(work[0]) ipiv, work, info, a, b = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], :lwork => lwork) assert_equal 0, info assert_equal lwork, get_int(work[0]) assert_narray @b_exp[rc], b assert_narray @ipiv_exp[rc], ipiv end define_method("test_#{method}_inquiring_lwork_oldargstyle") do rank, work, info, = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], :lwork => -1) assert_equal 0, info lwork = get_int(work[0]) rank, work, info, = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], -1) assert_equal 0, info assert_equal lwork, get_int(work[0]) end end end